岛屿数量

没树高

ynzsvt 发表于 2024-10-10 13:55
不可以，呈直角的三个，统计areas是两个，岛只算一个的。

我还是老老实实写代码吧，见第12楼。

没树高

1. Dim dictCheckedCells As Object
   
2. 
   
3. Sub IslandsTotal()
   
4. 
   
5.     Dim RangeToCheck As Range
   
6.     Set RangeToCheck = Sheet1.Range("A1:E5")
   
7.    
   
8.     Set dictCheckedCells = CreateObject("Scripting.Dictionary")
   
9.    
   
10.     Dim i%, j%
    
11.     Dim IslandsCount%
    
12.    
    
13.     For i = 1 To 5
    
14.         For j = 1 To 5
    
15.             If RangeToCheck(i, j) = 1 And _
    
16.                 dictCheckedCells.Exists(RangeToCheck(i, j).Address) = False Then
    
17.                
    
18.                 IslandsCount = IslandsCount + 1
    
19.                 dictCheckedCells.Add RangeToCheck(i, j), 1
    
20.                 Expand_the_Domain_of_1 RangeToCheck(i, j)
    
21.                
    
22.             End If
    
23.         Next j
    
24.     Next i
    
25.    
    
26.     MsgBox IslandsCount
    
27. 
    
28. End Sub
    
29. 
    
30. Sub Expand_the_Domain_of_1(Rng As Range) '递归函数：将连续的为“1”的单元格地址存入字典
    
31.       
    
32.     Dim RngRightward As Range, RngDownward As Range
    
33.     Set RngRightward = Rng.Offset(, 1) '右侧的单元格
    
34.     Set RngDownward = Rng.Offset(1) '下方的单元格
    
35.         
    
36.     If RngRightward.Column <= 5 And RngRightward = 1 Then
    
37.         dictCheckedCells.Add RngRightward.Address, 1
    
38.         Expand_the_Domain_of_1 RngRightward
    
39.     End If
    
40.    
    
41.     If RngDownward.Row <= 5 And RngDownward = 1 Then
    
42.         dictCheckedCells.Add RngDownward.Address, 1
    
43.         Expand_the_Domain_of_1 RngDownward
    
44.     End If
    
45. 
    
46. End Sub

复制代码

usedrange

参与学习一下

usedrange

截个图，感觉重点是清零。

yynrzwh

用递归，代码简洁点
Sub 岛屿数量()

ar = Range("a1").CurrentRegion
c = 0
For i = 1 To UBound(ar)
    For j = 1 To UBound(ar, 2)
        If ar(i, j) = 1 Then
            c = c + 1
            Call dfs(ar, i, j)
        End If
    Next
Next

MsgBox c
End Sub
Sub dfs(ar, row, col)

If row = 0 Or row = UBound(ar) + 1 Or col = 0 Or col = UBound(ar, 2) + 1 Then
    Exit Sub
End If

If ar(row, col) = 0 Then
    Exit Sub
End If

ar(row, col) = 0
Call dfs(ar, row + 1, col)
Call dfs(ar, row - 1, col)
Call dfs(ar, row, col + 1)
Call dfs(ar, row, col - 1)

End Sub

kevinchengcw

增加点难度玩下

yynrzwh

kevinchengcw 发表于 2024-10-11 09:29
增加点难度玩下

原代码稍微改一下

Dim s&
Sub test()
ar = Range("a1").CurrentRegion
c = 0
For i = 1 To UBound(ar)
    For j = 1 To UBound(ar, 2)
        If ar(i, j) > 0 Then
            c = c + 1
            s = 0
            Call dfs(ar, i, j)
            Cells(c, "x") = s
        End If
    Next
Next

MsgBox c
End Sub
Sub dfs(ar, row, col)

'If row = 0 Or row = UBound(ar) + 1 Or col = 0 Or col = UBound(ar, 2) + 1 Then
'    Exit Sub
'End If

If ar(row, col) = 0 Then
    Exit Sub
End If

s = s + 1
ar(row, col) = 0
Call dfs(ar, row + 1, col)
Call dfs(ar, row - 1, col)
Call dfs(ar, row, col + 1)
Call dfs(ar, row, col - 1)
Call dfs(ar, row + 1, col - 1)
Call dfs(ar, row + 1, col + 1)
Call dfs(ar, row - 1, col - 1)
Call dfs(ar, row - 1, col + 1)

End Sub

yynrzwh

进进阶版，扫雷