|
楼主 |
发表于 2017-3-26 11:52
|
显示全部楼层
万分感谢~~
大部分功能都实现了~~
我略微的做了一些适应性修改,另外我试图按照你之前的帖子,添加判断 Sheet2.A1 底色是否为未填充,最后失败了
你的源码:
If Cells(i, j).Interior.ColorIndex <> 6 Then
参照修改失败:
If ar(i, 8).Interior.ColorIndex = "0" Then d(ar(i, 2) & ar(i, 3) & ar(i, 8)) = d(ar(i, 2) & ar(i, 3) & ar(i, 8)) + 1
提示没有对象,是不能直接这么上么。。
期待你的回复
Sub zz()
Dim d, ar, sh As Worksheet
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare
ar = Sheet2.Range("A1").CurrentRegion
For i = 2 To UBound(ar)
ar(i, 2) = Replace(ar(i, 2), " ", " ")
d(ar(i, 2) & ar(i, 3) & ar(i, 8)) = d(ar(i, 2) & ar(i, 3) & ar(i, 8)) + 1
Next
sa = d.items
For Each sh In Sheets
If sh.Name <> "原始数据" Then
With sh
For i = 2 To .[a65536].End(3).Row
If .Cells(i, 3) <> "" Or .Cells(i, 4) <> "" Then
s1 = .Cells(i, 1) & .Cells(i, 2) & .Cells(i, 3)
s2 = .Cells(i, 1) & .Cells(i, 2) & .Cells(i, 4)
.Cells(i, 5) = ""
.Cells(i, 5) = d(s1) + d(s2)
Else
s1 = .Cells(i, 1) & .Cells(i, 2)
.Cells(i, 5) = ""
.Cells(i, 5) = d(s1) + 0
End If
Next
End With
End If
Next
End Sub
|
|