|
发表于 2016-4-23 18:12
|
显示全部楼层
本楼为最佳答案
- Sub Macro1()
- Dim arr, brr, crr, d, i&, j%
- Set d = CreateObject("scripting.dictionary")
- Sheet2.Activate
- arr = Range("a1").CurrentRegion
- brr = Sheets("数据").Range("a1").CurrentRegion
- ReDim crr(1 To UBound(arr) - 1, 1 To UBound(arr, 2) - 1)
- For i = 1 To UBound(brr)
- For j = 2 To 5
- zf = brr(i, 8) & "," & brr(1, j)
- If brr(i, j) <> "" Then
- d(zf) = d(zf) + 1
- Else
- If j = 3 Or j = 5 And brr(i, j - 1) <> "" Then
- zf = brr(i, 8) & "," & "未" & Mid(brr(1, j), 2)
- d(zf) = d(zf) + 1
- End If
- End If
- Next
- If brr(i, 6) = "1120" Then
- zf = brr(i, 8) & ",分类1120"
- Else
- zf = brr(i, 8) & ",分类非1120"
- End If
- d(zf) = d(zf) + 1
- If brr(i, 7) = "" Then
- zf = brr(i, 8) & ",种类情况空白"
- Else
- zf = brr(i, 8) & ",种类情况" & brr(i, 7)
- End If
- d(zf) = d(zf) + 1
- Next
- For j = 2 To UBound(arr, 2)
- s = 0
- For i = 2 To UBound(arr) - 1
- zf = arr(i, 1) & "," & arr(1, j)
- If d.exists(zf) Then
- crr(i - 1, j - 1) = d(zf)
- s = s + d(zf)
- End If
- Next
- crr(UBound(crr), j - 1) = s
- Next
- Range("b2").Resize(UBound(crr), UBound(crr, 2)) = crr
- End Sub
复制代码 |
|