|
Sub test()
Dim xRow&
Dim xRng As Range
Dim xDic As Object
Dim xArr1, xArr2
Dim hzRow&
Dim hzRng As Range
Set xDic = CreateObject("scripting.dictionary")
xRow = Sheet1.Range("A5").End(xlDown).Row
For Each xRng In Sheet1.Range("A6:A" & xRow)
If Mid(xRng, 1, 2) = "学校" Then
For i = 1 To 8
xDic(xRng & "," & xRng.Offset(0, i).Interior.Color) = xDic(xRng & "," & xRng.Offset(0, i).Interior.Color) + xRng.Offset(0, i)
Next
End If
Next
xArr1 = xDic.keys
xArr2 = xDic.items
With Sheet2
hzRow = .Range("A3").End(xlDown).Row
For Each hzRng In .Range("A3:A" & hzRow)
For i = 0 To UBound(xArr1)
If hzRng = Split(xArr1(i), ",")(0) Then
Debug.Print Split(xArr1(i), ",")(1)
If Split(xArr1(i), ",")(1) = CStr(hzRng.Offset(0, 4).Interior.Color) Then
hzRng.Offset(0, 4).Value = xArr2(i)
ElseIf Split(xArr1(i), ",")(1) = CStr(hzRng.Offset(0, 7).Interior.Color) Then
hzRng.Offset(0, 7).Value = xArr2(i)
ElseIf Split(xArr1(i), ",")(1) = CStr(hzRng.Offset(0, 10).Interior.Color) Then
hzRng.Offset(0, 10).Value = xArr2(i)
ElseIf Split(xArr1(i), ",")(1) = CStr(hzRng.Offset(0, 13).Interior.Color) Then
hzRng.Offset(0, 13).Value = xArr2(i)
End If
End If
Next
Next
End With
End Sub
楼主2个表之间的颜色还有不同的, 最好自己检查下, 绿色和蓝色要改成sheet1对应的颜色 |
|