Board logo

標題: [發問] 某條件下 不重復出現項目統計 [打印本頁]
作者: 棋語鳥鳴    時間: 2016-3-18 22:08     標題: 某條件下 不重復出現項目統計

請教各位大師:
如何用VBA統計某條件下 不重復出現項目統計，以下圖為列:條件則是102年1月A類別的不重復項目統計，
請問VBA該如何設定，因檔案太大(好幾萬筆數據)，用函數感覺跑好慢!
[attach]23485[/attach]
作者: 准提部林    時間: 2016-3-19 12:09

日期是什麼格式？
建議上傳檔案，
不要讓想幫忙的人再多花時間去建立測試資料！
作者: 棋語鳥鳴    時間: 2016-3-19 15:09

不好意思忘記補上附件，附件如下!

[attach]23487[/attach]
作者: 棋語鳥鳴    時間: 2016-3-19 15:09

回復 2# 准提部林
感謝提醒~附件以補上
作者: yen956    時間: 2016-3-19 15:38

本帖最後由 yen956 於 2016-3-19 15:58 編輯

'1. 可能是臨時 Key in 的關係, 欄A不是Excel的日期格式,
Sub 轉換為Excel日期格式()
Dim I As Integer, Ar
For I = 2 To Range("A" & Rows.Count).End(xlUp).Row
    Ar = Split(Cells(I, 1), ".")
    x = Trim(Str(Val(Ar(0)) + 1911)) & "/" & Ar(1) & "/" & Ar(2)
    Cells(I, 1) = Trim(Str(Val(Ar(0)) + 1911)) & "/" & Ar(1) & "/" & Ar(2)
Next
End Sub

'2. 若 類別 長度一樣
  1. Sub CountDist()
  2.     Dim Rng As Range, I As Integer, s1 As String, E
  3.     Set d = CreateObject("Scripting.Dictionary")
  4.     [F5:Q5] = "": [F9:Q9] = ""
  5.     Set Rng = Range([A2], "A" & Range("A" & Rows.Count).End(xlUp).Row)
  6.    
  7.     For Each E In Rng
  8.         d(Str(Month(E.Value)) & E(1, 3).Value & E(1, 2)) = Month(E.Value)
  9.     Next
  10.         
  11.     For I = 0 To d.Count - 1
  12.         If Right(d.keys()(I), 1) = "A" Then       '若 類別 為 "A"(長度為1)
  13.             Cells(5, d.items()(I) + 5) = Cells(5, d.items()(I) + 5) + 1
  14.         ElseIf Right(d.keys()(I), 1) = "B" Then   '若 類別 為 "B"(長度為1)
  15.             Cells(9, d.items()(I) + 5) = Cells(9, d.items()(I) + 5) + 1
  16.         End If
  17.     Next
  18. End Sub
  19. '3. 若 類別 長度不一
  20. Sub CountDist2()
  21.     Dim Rng As Range, I As Integer, s1 As String, E
  22.     Set d = CreateObject("Scripting.Dictionary")
  23.     [F5:Q5] = "": [F9:Q9] = ""
  24.     Set Rng = Range([A2], "A" & Range("A" & Rows.Count).End(xlUp).Row)
  25.    
  26.     For Each E In Rng
  27.         '輔助欄(欄S), 將 類別 左邊用 # 字元補足為10個字元
  28.         E(1, 19) = "=right(""#########""&RC[-17],10)"
  29.         d(Str(Month(E.Value)) & E(1, 3).Value & E(1, 19)) = Month(E.Value)
  30.     Next
  31.    
  32.     For I = 0 To d.Count - 1
  33.         If Right(d.keys()(I), 3) = "Axx" Then       '若 類別 為 "Axx"(長度為3)
  34.             Cells(5, d.items()(I) + 5) = Cells(5, d.items()(I) + 5) + 1
  35.         ElseIf Right(d.keys()(I), 2) = "Bx" Then    '若 類別 為 "Bx"(長度為2)
  36.             Cells(9, d.items()(I) + 5) = Cells(9, d.items()(I) + 5) + 1
  37.         End If
  38.     Next
  39. End Sub
複製代碼
[attach]23488[/attach]
作者: 棋語鳥鳴    時間: 2016-3-19 16:33

回復 5# yen956
請問如果要加年分的判斷式，要如何加?目前好像只統計月份!
想改為102年1月------
因有時會有多年的資料丟一起
謝謝~~
作者: 准提部林    時間: 2016-3-19 19:09

全部〔類別〕各〔年月〕不重覆全列出來：
  1. Sub TEST()
  2. Dim Arr, Brr, xD(1 To 3), i&, T1, T2, T3, R&, C%
  3. [E:IV].Clear
  4. For i = 1 To 3: Set xD(i) = CreateObject("Scripting.Dictionary"): Next
  5. Arr = Range([A1], [C65536].End(xlUp))
  6. ReDim Brr(1 To UBound(Arr), 1 To 200): Brr(1, 1) = "類別"

  8. For i = 2 To UBound(Arr)
  9.     T1 = Replace(Left(Arr(i, 1), 6), ".", "年"): If T1 = "" Then GoTo 101
  10.     C = xD(1)(T1)
  11.     If C = 0 Then C = xD(1).Count: xD(1)(T1) = C: Brr(1, C + 1) = T1 & "月"

  13.     T2 = Arr(i, 2): If T2 = "" Then GoTo 101
  14.     R = xD(2)(T2)
  15.     If R = 0 Then R = xD(2).Count: xD(2)(T2) = R: Brr(R + 1, 1) = T2

  17.     T3 = Arr(i, 3): If T3 = "" Then GoTo 101
  18.     If xD(3)(T1 & T2 & T3) = 0 Then Brr(R + 1, C + 1) = Brr(R + 1, C + 1) + 1
  19.     xD(3)(T1 & T2 & T3) = 1
  20. 101: Next

  22. With [E4].Resize(xD(2).Count + 1, xD(1).Count + 1)
  23.      .Value = Brr
  24.      .Offset(, 1).Sort Key1:=.Item(1), Order1:=xlAscending, Header:=xlNo, Orientation:=xlLeftToRight '橫排序
  25.      .Offset(1, 0).Sort Key1:=.Item(1), Order1:=xlAscending, Header:=xlNo, Orientation:=xlTopToBottom '直排序
  26.      .Borders.LineStyle = 1
  27. End With
  28. End Sub
複製代碼

　
　
[attach]23489[/attach]
作者: yen956    時間: 2016-3-20 04:31

回復 7# 准提部林
謝謝大大的指導, 又要好好的研究一下了, 謝謝!!
作者: 棋語鳥鳴    時間: 2016-3-20 23:17

回復 7# 准提部林
感謝指導...受教了~~



歡迎光臨 麻辣家族討論版版 (http://forum.twbts.com/)