請教各位前輩vba 關於單一儲存格式內統計問題~

1^# 跳轉到 »

發表於 2014-5-26 19:49 | 顯示全部帖子

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

回復 1# ii31sakura
僅供參考
最好的做法還是一開始的表格就先定義明確，單一儲存格不要多用途。

Sub Test()
Dim d, i As Long, dteDate As Date, lValue As Long, sType As String
Dim oReg, oMatch, x, y, lCnt As Long, ar
Set d = CreateObject("scripting.dictionary")
Set oReg = CreateObject("vbscript.regexp")
With oReg
.Global = True
.Pattern = "(\d+)-(\S+)"
End With
'Analyze
With Sheets("Sheet1").[A1].CurrentRegion
If .Rows.Count < 2 Then Exit Sub
For i = 2 To .Rows.Count
dteDate = .Cells(i, 1).Value
'make 2 levels dictionary
If Not d.exists(dteDate) Then Set d(dteDate) = CreateObject("scripting.dictionary")
Set oMatch = oReg.Execute(.Cells(i, 2).Value)
For Each x In oMatch
lValue = CLng(oReg.Replace(x.Value, "$1"))
sType = oReg.Replace(x.Value, "$2")
With d(dteDate)
If .exists(sType) Then
.Item(sType) = .Item(sType) + lValue
Else
.Item(sType) = lValue
lCnt = lCnt + 1
End If
End With
Next
Next
End With
'Read to array
ReDim ar(1 To lCnt, 1 To 3)
i = 0
For Each x In d.keys
For Each y In d(x).keys
i = i + 1
ar(i, 1) = x
ar(i, 2) = y
ar(i, 3) = d(x)(y)
Next
Next
'Fill into worksheet
With Sheets("Sheet1").[F1]
.Resize(1, 3).Value = Array("日期", "其它項目", "其它總數量(顆粒數)")
.Offset(1).Resize(lCnt, 3).Value = ar
End With
End Sub

複製代碼

靜思自在 : 話多不如話少，話少不如話好。