- Sub Macro1()
- Dim arr, brr, crr, d, i%, j&, k%
- Set d = CreateObject("scripting.dictionary")
- brr = Range("a3").CurrentRegion
- ReDim crr(1 To UBound(brr) - 2, 1 To 10)
- For i = 1 To Sheets.Count - 1
- dgb = Split(Sheets(i).Name, "(")(1)
- dm = Left(dgb, Len(dgb) - 1)
- arr = Sheets(i).Range("a1").CurrentRegion
- For j = 4 To UBound(arr) - 1
- If arr(j, 2) = "" Then arr(j, 2) = arr(j - 1, 2)
- If arr(j, 4) = "" Then arr(j, 4) = arr(j - 1, 4)
- zf = arr(j, 2) & "," & arr(j, 4) & "," & arr(j, 5)
- For k = 6 To 14
- d(zf & "," & arr(3, k)) = d(zf & "," & arr(3, k)) + arr(j, k)
- Next
- If arr(j, 15) = "√" Then
- zf2 = zf & "," & "打勾"
- If Not d.exists(zf2) Then d(zf2) = dm Else d(zf2) = d(zf2) & ";" & dm
- End If
- Next
- Next
- For j = 2 To UBound(brr) - 1
- If brr(j, 2) = "" Then brr(j, 2) = brr(j - 1, 2)
- If brr(j, 4) = "" Then brr(j, 4) = brr(j - 1, 4)
- zf = brr(j, 2) & "," & brr(j, 4) & "," & brr(j, 5)
- crr(j - 1, 10) = d(zf & "," & "打勾")
- For k = 6 To 14
- crr(j - 1, k - 5) = d(zf & "," & brr(1, k))
- Next
- Next
- Range("f4").Resize(UBound(crr), 10) = crr
- End Sub
复制代码 |