Sub nn()
Set d = CreateObject("Scripting.Dictionary")
Set d1 = CreateObject("Scripting.Dictionary")
With Sheet1
For Each a In .Range(.[A2], .[A65536].End(xlUp))
mystr = a.Offset(, 1) & a.Offset(, 2) & a.Offset(, 3) & a.Offset(, 4) & a.Offset(, 5)
If IsEmpty(d(mystr)) Then
ar = a.Resize(, 6).Value
d(mystr) = a.Resize(, 6).Value
d1(mystr) = 1
Else
ar = d(mystr)
ar(1, 6) = ar(1, 6) + Val(a.Offset(, 5))
d1(mystr) = d1(mystr) + 1
End If
Next
End With
With Sheet2
.[A2:G65536] = ""
.[A2].Resize(d.Count, 6) = Application.Transpose(Application.Transpose(d.items))
.[G2].Resize(d.Count, 1) = Application.Transpose(d1.items)
End With
End Sub作者: Hsieh 時間: 2010-5-7 08:31
本帖最後由 Hsieh 於 2010-5-9 21:50 編輯
你自己沒嚐試去改改看嗎?
了解整體流程語法的意義後
要修改並不困難
你應該把你修改過程中無法克服的地方拿出來討論
而非要別人直接修好給你
Sub nn()
Dim d As Object, d1 As Object, a As Range, mystr As String
Set d = CreateObject("Scripting.Dictionary")
Set d1 = CreateObject("Scripting.Dictionary")
t = Timer
With Sheet1
For Each a In .Range(.[A2], .[A65536].End(xlUp))
mystr = Join(Application.Transpose(Application.Transpose(a.Offset(, 1).Resize(, 5))), "")
If IsEmpty(d(mystr)) Then
Ar = a.Offset(, 1).Resize(, 5).Value
d(mystr) = a.Offset(, 1).Resize(, 5).Value
d1(mystr) = 1
Else
Ar = d(mystr)
Ar(1, 5) = Ar(1, 5) + Val(a.Offset(, 5))
d1(mystr) = d1(mystr) + 1
End If
Next
End With
With Sheet2
.[A2:F65536] = ""
.[A2].Resize(d.Count, 5) = Application.Transpose(Application.Transpose(d.items))
.[F2].Resize(d.Count, 1) = Application.Transpose(d1.items)
End With
Application.ScreenUpdating = True
MsgBox Timer - t
End Sub作者: GBKEE 時間: 2010-5-7 19:45
回復 1#天嵐
Sub Ex()
Dim A, Text$, i%
Set d = CreateObject("Scripting.Dictionary")
With Sheets("Date")
For Each A In .Range(.[b2], .[b65536].End(xlUp))
Text = Join(Application.Transpose(Application.Transpose(A.Resize(, 5).Value)), "-")
If d.EXISTS(Text) Then
d(Text) = d(Text) + 1
Else
d(Text) = 1
End If
Next
End With
Application.ScreenUpdating = False
With Sheets("Result")
.Range("a1").CurrentRegion.Offset(1) = ""
i = 2
For Each A In d.keys
.Cells(i, "A").Resize(, 5) = Split(A, "-")
.Cells(i, "F") = d(A)
i = i + 1
Next
End With
Application.ScreenUpdating = True
End Sub作者: 天嵐 時間: 2010-5-9 12:50
已修改成這句, 可以達到目標, 但逐行貼上, 速度太慢, 可以簡化嗎
For i = 1 To D.Count
.Cells(1 + i, 1).Resize(1, 1) = Application.Transpose(Application.Transpose(D.items))(i, 4)
NEXT作者: luhpro 時間: 2010-5-9 16:17
我覺得這個 Case 不使用 Dictionary 反而可能會更快呢, 程式如下 :
Sub Ex()
Dim i%, j%, iSou%, iRes%, Text$
Dim rC As Range
Sheets("Result").Range("A2:G65536").Clear
iRes = 2
With Sheets("Date")
iSou = .Range("B65536").End(xlUp).Row
With Sheets("Result")
Set rC = .Range(.Cells(2, 7), .Cells(iRes, 7)).Find(Text, LookIn:=xlValues)
If Not rC Is Nothing Then
i = rC.Row
.Cells(i, 6) = .Cells(i, 6) + 1
Else
.Cells(iRes, 7) = Text
.Cells(iRes, "A").Resize(, 5) = Split(Text, "-")
.Cells(iRes, 6) = 1
iRes = iRes + 1
End If
End With
Next j
End With
Sheets("Result").Range("G2:G65536").Clear
End Sub作者: GBKEE 時間: 2010-5-9 19:07
回復 4#天嵐
Sub Ex()
Dim D As Object, A As Range, Ar1(), Ar2()
Set D = CreateObject("Scripting.Dictionary")
With Sheets("Date")
For Each A In .Range(.[b2], .[b65536].End(xlUp))
Ar1 = Application.Transpose(Application.Transpose(A.Resize(, 5).Value))
Ar2 = Application.Transpose(Application.Transpose(A.Resize(, 6).Value))
If D.EXISTS(Join(Ar1, "")) Then
Ar2(6) = D(Join(Ar1, ""))(6) + 1
D(Join(Ar1, "")) = Ar2
Else
Ar2(6) = 1
D(Join(Ar1, "")) = Ar2
End If
Next
End With
Application.ScreenUpdating = False
With Sheets("Result")
.Range("a1").CurrentRegion.Offset(1) = ""
.[A2].Resize(D.Count, 6) = Application.Transpose(Application.Transpose(D.items))
End With
Application.ScreenUpdating = True
End Sub作者: GBKEE 時間: 2010-5-9 19:49
回復 5#luhpro Vba 的解法有許多 端看個人喜好 Sub Ex()
Dim Ar(), j%, Text$, R
Sheets("Result").Range("A2:G65536").Clear
With Sheets("Date")
ReDim Ar(0)
Ar(0) = Join(Application.Transpose(Application.Transpose(.[A1].Resize(1, 5))), "-")
For j = 2 To .Range("B65536").End(xlUp).Row
' 套用 Join 方法搭配 Cells Text = Join(Application.Transpose(Application.Transpose(.Cells(j, "B").Resize(1, 5))), "-")
R = Application.Match(Text, Ar, 0)
With Sheets("Result")
If Not IsNumeric(R) Then
ReDim Preserve Ar(UBound(Ar) + 1)
Ar(UBound(Ar)) = Text
.Cells(UBound(Ar) + 1, "A").Resize(1, 5) = Split(Text, "-")
.Cells(UBound(Ar) + 1, "F") = 1
Else
.Cells(R, "F") = .Cells(R, "F") + 1
End If
End With
Next j
End With
End Sub作者: 天嵐 時間: 2010-5-9 23:17
