|
本帖最后由 一把小刀闯天下 于 2019-6-10 22:38 编辑
'首选应该使用字典。不用字典来个,当数据量大时换快排
Option Explicit
Sub test()
Dim arr, i, j, k, t, m, sum
arr = Sheets("sheet1").[a1].CurrentRegion.Offset(2)
For i = 1 To UBound(arr, 1) - 3
For j = i + 1 To UBound(arr, 1) - 2
If StrComp(arr(i, 1), arr(j, 1), vbTextCompare) = 1 Then
For k = 1 To UBound(arr, 2)
t = arr(i, k): arr(i, k) = arr(j, k): arr(j, k) = t
Next
End If
Next j, i
ReDim sum(2 To UBound(arr, 2))
For i = 1 To UBound(arr, 1) - 2
For j = 2 To UBound(arr, 2)
If Len(arr(i, j)) Then sum(j) = sum(j) + arr(i, j)
Next
If arr(i, 1) <> arr(i + 1, 1) Then
m = m + 1: arr(m, 1) = arr(i, 1)
For j = 2 To UBound(arr, 2): arr(m, j) = sum(j): Next
ReDim sum(2 To UBound(arr, 2))
End If
Next
With Sheets("sheet2").[a3]
.Resize(Rows.Count - 3, UBound(arr, 2)).ClearContents
.Resize(m, UBound(arr, 2)) = arr
End With
End Sub |
|