|
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件 ★ 免费下载 ★ ★ 使用帮助★
Sub test()
Dim dic1 As Object, dic2 As Object
Set dic1 = CreateObject("Scripting.Dictionary")
Set dic2 = CreateObject("Scripting.Dictionary")
Dim rng As Range
Dim r As Long
Dim colArr
With Sheet7
r = .Range("B2").End(xlDown).Row
For Each rng In .Range("B3:B" & r)
dic1(rng.Interior.ColorIndex) = dic1(rng.Interior.ColorIndex)
Next
colArr = dic1.keys
dic1.RemoveAll
For i = 0 To UBound(colArr)
For Each rng In .Range("B3:B" & r)
If colArr(i) = rng.Interior.ColorIndex Then
dic1(rng & "," & rng.Offset(0, 1) & "," & rng.Offset(0, 2)) = dic1(rng & "," & rng.Offset(0, 1) & "," & rng.Offset(0, 2))
End If
Next
Dim arr1, arr2, arr3, arr4
arr1 = dic1.keys
For j = 0 To UBound(arr1)
arr2 = Split(arr1(j), ",")
dic2(arr2(0) & "," & arr2(1)) = dic2(arr2(0) & "," & arr2(1)) & "," & arr2(2)
Erase arr2
Next
arr3 = dic2.keys
arr4 = dic2.items
m = .Range("F50000").End(xlUp).Row
For n = 0 To UBound(arr3)
.Cells(m + 1 + n, 6) = Split(arr3(n), ",")(0)
.Cells(m + 1 + n, 7).Interior.ColorIndex = colArr(i)
.Cells(m + 1 + n, 7) = Split(arr3(n), ",")(1)
.Cells(m + 1 + n, 8).Interior.ColorIndex = colArr(i)
.Cells(m + 1 + n, 8) = arr4(n)
Next
Erase arr1
Erase arr2
Erase arr3
Erase arr4
dic1.RemoveAll
dic2.RemoveAll
Next
End With
End Sub |
评分
-
1
查看全部评分
-
|