利用EXCEL巨集資料處理
如何修改以下宏, 把結果從欄位"訂貨單" 開始貼在result 上?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 [i=s] 本帖最後由 Hsieh 於 2010-5-9 21:50 編輯 [/i]
你自己沒嚐試去改改看嗎?
了解整體流程語法的意義後
要修改並不困難
你應該把你修改過程中無法克服的地方拿出來討論
而非要別人直接修好給你
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 [b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=250&ptid=110]1#[/url] [i]天嵐[/i] [/b]
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 已修改成這句, 可以達到目標, 但逐行貼上, 速度太慢, 可以簡化嗎
For i = 1 To D.Count
.Cells(1 + i, 1).Resize(1, 1) = Application.Transpose(Application.Transpose(D.items))(i, 4)
NEXT 我覺得這個 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
For j = 2 To iSou
' 這邊原想要套用 Join 方法但搭配 Cells 一直都說 "執行錯誤", 所以只能暫時先這樣用囉.
Text = .Cells(j, 2) & "-" & .Cells(j, 3) & "-" & .Cells(j, 4) & "-" & .Cells(j, 5) & "-" & .Cells(j, 6)
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 [b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=473&ptid=110]4#[/url] [i]天嵐[/i] [/b]
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 [b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=480&ptid=110]5#[/url] [i]luhpro[/i] [/b]
[b]Vba 的解法有許多 端看個人喜好[/b]
[b]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 [/b]
[b] 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[/b] 試驗後. 都是 .Dictionary 較快, Split(Text, "-")<< 較耗時, 謝謝各大大! [b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=480&ptid=110]5#[/url] [i]luhpro[/i] [/b]
[b]這邊原想要套用 Join 方法但搭配 Cells 一直都說 "執行錯誤", 所以只能暫時先這樣用囉.[/b]
這是因為當你指定一列的範圍做陣列時
事實上excel把此範圍看成2維陣列
而join函數的參數只能允許一維陣列 謝謝論壇,謝謝各位前輩
後學藉此帖練習陣列與字典,學習方案如下,請各位前輩指教
資料表:
[attach]36356[/attach]
結果表:
[attach]36357[/attach]
Option Explicit
Sub TEST()
Dim Brr, Crr, Y, R1&, R&, i&, j&, TT$, T2$, T3$, T4$, T5$
[color=SeaGreen]'↑宣告變數[/color]
Set Y = CreateObject("Scripting.Dictionary")
[color=SeaGreen]'↑令Y變數是 字典[/color]
Brr = Range([Date!F2], [Date!A65536].End(xlUp))
[color=SeaGreen]'↑令Brr變數是 二維陣列,以資料表儲存格值帶入[/color]
ReDim Crr(1 To 1000, 1 To 7)
[color=SeaGreen]'↑宣告Crr變數是二維空陣列,縱向索引號1~1000,橫向1~7[/color]
For i = 1 To UBound(Brr)
[color=SeaGreen]'↑設順迴圈[/color]
T2 = Brr(i, 2): T3 = Brr(i, 3): T4 = Brr(i, 4): T5 = Brr(i, 5)
[color=SeaGreen] '↑令T2~T5變數裝入陣列值[/color]
TT = T2 & "|" & T3 & "|" & T4 & "|" & T5
[color=SeaGreen] '↑令TT變數是組合字串,用來濾重複用的key[/color]
If Y(TT) = "" Then
[color=SeaGreen] '↑如果以TT變數查Y字典得item值是""[/color]
R = R + 1
[color=SeaGreen] '↑令R變數累加1 (用來累加Crr陣列這結果陣列的列號)[/color]
For j = 1 To 4: Crr(R, j) = Brr(i, j + 1): Next
[color=SeaGreen] '↑將Brr陣列2~5欄寫入Crr陣列(1~4)欄指定的R變數列號[/color]
Crr(R, 5) = Val(Brr(i, 6))
[color=SeaGreen] '↑Crr陣列第5欄放入資料表的數量 (用Val()將字串轉為數值)[/color]
Crr(R, 6) = 1
[color=SeaGreen] '↑Crr陣列第6欄是寫入1 (第1箱)[/color]
Crr(R, 7) = Brr(i, 1)
[color=SeaGreen] '↑Crr陣列第7欄是寫入箱號 (第1箱號)[/color]
Y(TT) = R: GoTo i01
[color=SeaGreen] '↑令以TT變數為key,item是 R變數(列號),納入Y字典中
'令程序跳到標示 i01位置繼續執行[/color]
End If
R1 = Y(TT)
[color=SeaGreen] '↑令R1變數是 以TT變數查Y字典得item值 (用來指向Crr陣列列號)
'是第2次以上出現的key才會跑到這裡[/color]
Crr(R1, 5) = Crr(R1, 5) + Val(Brr(i, 6))
[color=SeaGreen] '↑令數量累加[/color]
Crr(R1, 6) = Crr(R1, 6) + 1
[color=SeaGreen] '↑令箱數累加[/color]
Crr(R1, 7) = Crr(R1, 7) & "," & Brr(i, 1)
[color=SeaGreen] '↑令箱號添加在Crr陣列第7欄後面[/color]
i01: Next
With [Result!A2].Resize(R, 7)
[color=SeaGreen]'↑以下是關於結果表預計要寫入新結果範圍儲存格的程序[/color]
.EntireColumn.Clear
[color=SeaGreen] '↑令這些欄位做清除[/color]
[Result!A1:G1] = [{"訂貨單","板號","料號","原產地","數量合計","箱數","箱號註記"}]
[color=SeaGreen] '↑令結果表寫入標題列[/color]
.Value = Crr
[color=SeaGreen] '↑令Crr陣列值寫入這些範圍儲存格,超過此範圍的陣列值忽略[/color]
.EntireColumn.AutoFit
[color=SeaGreen] '↑令這些欄位欄寬自動調整[/color]
Intersect(.Cells, [G:G]).NumberFormatLocal = "@"
[color=SeaGreen] '↑令第7欄的格式是 文字[/color]
End With
Set Y = Nothing: Erase Brr, Crr
[color=SeaGreen]'↑令釋放變數[/color]
End Sub
頁:
[1]