Board logo

標題: 請教各位前輩vba 關於單一儲存格式內統計問題~ [打印本頁]
作者: ii31sakura    時間: 2014-5-26 17:05     標題: 請教各位前輩vba 關於單一儲存格式內統計問題~

請問各位大大因小弟所碰到資料型態如下、卻也需進行統計，請問此種資料形態使用vba有辨法統計嗎？
不好意思因此種單一儲存格進行統計、小弟不知道如何著手進行..所以請麻煩各位大大了。

附件說明如下：
1. A & B 欄為資料DATA清單
2.主要問題為B欄所使用的是KEY in 在一起的資料形態，例"B2" = 20-蘋果 (按ENTER至同一格下方續KEY in)  50-香蕉  ，
    並且出現的項目不一定、只知道單一儲存格式為 例"B6"： ( 數量 -項目 ) or ( 數量 -項目 +enter 數量 -項目)

3.如可進行統計、請問要怎麼像"F:H"欄情況列出如此種的統計清單出來呢？(附件內容"F:H"為用手key in上去..)


感謝~
作者: stillfish00    時間: 2014-5-26 19:49

本帖最後由 stillfish00 於 2014-5-26 19:59 編輯

回復 1# ii31sakura
僅供參考
最好的做法還是一開始的表格就先定義明確，單一儲存格不要多用途。
  1. Sub Test()
  2.   Dim d, i As Long, dteDate As Date, lValue As Long, sType As String
  3.   Dim oReg, oMatch, x, y, lCnt As Long, ar
  4.   
  5.   Set d = CreateObject("scripting.dictionary")
  6.   Set oReg = CreateObject("vbscript.regexp")
  7.   With oReg
  8.     .Global = True
  9.     .Pattern = "(\d+)-(\S+)"
  10.   End With
  11.   
  12.   'Analyze
  13.   With Sheets("Sheet1").[A1].CurrentRegion
  14.     If .Rows.Count < 2 Then Exit Sub
  15.     For i = 2 To .Rows.Count
  16.       dteDate = .Cells(i, 1).Value
  17.       'make 2 levels dictionary
  18.       If Not d.exists(dteDate) Then Set d(dteDate) = CreateObject("scripting.dictionary")
  19.       
  20.       Set oMatch = oReg.Execute(.Cells(i, 2).Value)
  21.       For Each x In oMatch
  22.         lValue = CLng(oReg.Replace(x.Value, "$1"))
  23.         sType = oReg.Replace(x.Value, "$2")
  24.         With d(dteDate)
  25.           If .exists(sType) Then
  26.             .Item(sType) = .Item(sType) + lValue
  27.           Else
  28.             .Item(sType) = lValue
  29.             lCnt = lCnt + 1
  30.           End If
  31.         End With
  32.       Next
  33.     Next
  34.   End With
  35.   
  36.   'Read to array
  37.   ReDim ar(1 To lCnt, 1 To 3)
  38.   i = 0
  39.   For Each x In d.keys
  40.     For Each y In d(x).keys
  41.       i = i + 1
  42.       ar(i, 1) = x
  43.       ar(i, 2) = y
  44.       ar(i, 3) = d(x)(y)
  45.     Next
  46.   Next
  47.   'Fill into worksheet
  48.   With Sheets("Sheet1").[F1]
  49.     .Resize(1, 3).Value = Array("日期", "其它項目", "其它總數量(顆粒數)")
  50.     .Offset(1).Resize(lCnt, 3).Value = ar
  51.   End With
  52. End Sub
複製代碼
作者: ii31sakura    時間: 2014-5-27 09:23

回復 2# stillfish00


    stillfish00大大說的沒錯、最好的方法是單一儲存格單用途，
    只是因小弟碰到的是像此種類型的key in方式且格式目前只能鎖定此種key法但又需去統計裡面有什麼、所以很感謝stillfish00大大的幫忙哦~
作者: Hsieh    時間: 2014-5-27 15:07

回復 1# ii31sakura
  1. Sub ex()
  2. Set d = CreateObject("Scripting.Dictionary")
  3. For Each a In Range([A2], [A2].End(xlDown)) '每日
  4. ar = Split(a.Offset(, 1), Chr(10)) '換行資料
  5. For Each k In ar
  6.    s = Split(k, "-")(0): p = Split(k, "-")(1) '取得數量與品名
  7.    If IsEmpty(d(a & p)) Then '寫入字典
  8.       d(a & p) = Array(a.Value, p, Val(s))
  9.       Else
  10.       d(a & p) = Array(a.Value, p, d(a & p)(2) + Val(s))
  11.    End If
  12. Next
  13. Next
  14. [F2].Resize(d.Count, 3) = Application.Transpose(Application.Transpose(d.items)) '寫入工作表
  15. End Sub
複製代碼
作者: c_c_lai    時間: 2014-5-27 16:12

回復 4# Hsieh
很不錯的 "Scripting.Dictionary" 應用，
謝謝您指導！
作者: ii31sakura    時間: 2014-5-29 18:05

回復 4# Hsieh


    很感謝Hsieh大大提供的另一種方法、讓小弟可以學到更多，感謝大家的幫忙哦~
作者: Andy2483    時間: 2023-4-18 09:51

謝謝論壇,謝謝各位前輩
後學藉此帖練習陣列與字典,學習方案如下,請前輩們指教

執行前:
[attach]36168[/attach]

執行結果:
[attach]36169[/attach]


Option Explicit
Sub TEST()
Dim Brr, Crr(1 To 100, 1 To 3), Y, Z, R&, R1&, i&, j&
Dim xR As Range, TT$, T1$, B$, A$
Set Y = CreateObject("Scripting.Dictionary")
Set xR = Range([B1], Cells(Rows.Count, "A").End(3)): Brr = xR
For i = 2 To UBound(Brr)
   If i = 2 Then R = 1: Crr(R, 1) = "日期": Crr(R, 2) = "項目": Crr(R, 3) = "總數"
   Z = Split(Brr(i, 2), vbLf): T1 = Brr(i, 1)
   For j = 0 To UBound(Z)
      A = Split(Z(j), "-")(0): B = Split(Z(j), "-")(1): TT = T1 & "|" & B
      If Y(TT) = "" Then
         R = R + 1: R1 = R: Y(TT) = R1
         Crr(R1, 1) = Brr(i, 1): Crr(R1, 2) = B
         Else
         R1 = Y(TT)
      End If
      Crr(R1, 3) = Crr(R1, 3) + Val(A)
   Next
Next
With [J1].Resize(R, 3)
   .EntireColumn.ClearContents
   .Value = Crr
   .Sort KEY1:=.Item(1), Order1:=1, _
         Key2:=.Item(2), Order2:=1, Header:=1
End With
Set Y = Nothing: Set xR = Nothing: Erase Brr, Crr, Z
End Sub



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