某條件下不重復出現項目統計 - Excel程式區

[發問] 某條件下不重復出現項目統計

1^# 跳轉到 »

發表於 2016-3-19 12:09 | 顯示全部帖子

日期是什麼格式？
建議上傳檔案，
不要讓想幫忙的人再多花時間去建立測試資料！

2^#

發表於 2016-3-19 19:09 | 顯示全部帖子

全部〔類別〕各〔年月〕不重覆全列出來：

Sub TEST()
Dim Arr, Brr, xD(1 To 3), i&, T1, T2, T3, R&, C%
[E:IV].Clear
For i = 1 To 3: Set xD(i) = CreateObject("Scripting.Dictionary"): Next
Arr = Range([A1], [C65536].End(xlUp))
ReDim Brr(1 To UBound(Arr), 1 To 200): Brr(1, 1) = "類別"
For i = 2 To UBound(Arr)
T1 = Replace(Left(Arr(i, 1), 6), ".", "年"): If T1 = "" Then GoTo 101
C = xD(1)(T1)
If C = 0 Then C = xD(1).Count: xD(1)(T1) = C: Brr(1, C + 1) = T1 & "月"
T2 = Arr(i, 2): If T2 = "" Then GoTo 101
R = xD(2)(T2)
If R = 0 Then R = xD(2).Count: xD(2)(T2) = R: Brr(R + 1, 1) = T2
T3 = Arr(i, 3): If T3 = "" Then GoTo 101
If xD(3)(T1 & T2 & T3) = 0 Then Brr(R + 1, C + 1) = Brr(R + 1, C + 1) + 1
xD(3)(T1 & T2 & T3) = 1
101: Next
With [E4].Resize(xD(2).Count + 1, xD(1).Count + 1)
.Value = Brr
.Offset(, 1).Sort Key1:=.Item(1), Order1:=xlAscending, Header:=xlNo, Orientation:=xlLeftToRight '橫排序
.Offset(1, 0).Sort Key1:=.Item(1), Order1:=xlAscending, Header:=xlNo, Orientation:=xlTopToBottom '直排序
.Borders.LineStyle = 1
End With
End Sub

複製代碼

20160319(不重復統計).rar (11.51 KB)

靜思自在 : 吃苦了苦、苦盡廿來，享福了福、福盡悲來。