返回列表 上一主題 發帖

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

本帖最後由 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
複製代碼
test.gif

TOP

回復 7# 准提部林
謝謝大大的指導, 又要好好的研究一下了, 謝謝!!

TOP

        靜思自在 : 真正的愛心,是照顧好自己的這顆心。
返回列表 上一主題