|
本帖最后由 422566739 于 2025-1-15 07:10 编辑
’请测试效果
Sub hebing()
Dim sht1 As Worksheet
Set sht1 = Worksheets("与土地变更调查数据相交表")
Dim d As Object
Set dic = CreateObject("Scripting.Dictionary")
sht1.Range("p2:p8819").ClearContents
arr1 = sht1.Range("l2:p8819")
xd = 0
For i = 1 To UBound(arr1)
'把每条数据都放入字典
If Not dic.Exists(arr1(i, 2)) Then
dic(arr1(i, 2)) = Round(arr1(i, 3), 2)
Else
dic(arr1(i, 2)) = dic(arr1(i, 2)) + Round(arr1(i, 3), 2)
End If
If i < 8818 Then
If arr1(i, 1) = arr1(i + 1, 1) Then
xd = xd + 1
Else
'下一个不相同 有2种情况
'1上面有相等过的,2是没有相等过的
If xd < 1 Then
arr1(i, 5) = "宗地范围内存在 " & arr1(i, 2) & Round(arr1(i, 3), 2) & "亩"
dic.RemoveAll
Else
n = ""
n1 = 0
For Each Key In dic.keys()
x = n & Key & dic(Key) & "亩,"
n = x
tot = dic(Key) + n1
n1 = tot
Next
arr1(i, 5) = "宗地范围内存在" & x & "共计 " & n1 & "亩"
dic.RemoveAll
End If
End If
End If
Next
sht1.Range("l2:L20000").NumberFormat = "@"
sht1.Range("l2:p8819") = arr1
End Sub
|
|