Option Explicit
'這方案是以字典key記錄不重複的貨號,item記錄相同貨號所在列號,以"/"間隔
Sub TEST_1()
Application.DisplayAlerts = False
'↑令不必詢問工作表是否刪除,直接刪了
Dim Brr, Crr, Z, Q, A, i&, j%, s%, N%
'↑宣告變數:&是長整數,%是短整數,其餘是通用變數
Set Z = CreateObject("Scripting.Dictionary")
'↑令Z變數是 字典
For Each A In Worksheets
If A.Name <> "總表" Then A.Delete
Next
'↑設順迴圈將"總表"以外的工作表刪除
Brr = [A1].CurrentRegion: Crr = Brr
'↑令Brr變數是帶入區域儲存格值的二維陣列,令Crr變數同Brr陣列
For i = 3 To UBound(Brr): Z(Brr(i, 2)) = Z(Brr(i, 2)) & "/" & i: Next
'↑設順迴圈將貨號濾重複,但是以item記錄所在的列號,以"/"符號間隔
For s = 0 To Z.Count - 1
Q = Split(Z.ITEMS()(s), "/"): N = 2
For i = 1 To UBound(Q)
N = N + 1
For j = 1 To 8: Crr(N, j) = Brr(Q(i), j): Next
Next
Worksheets.Add.Name = Z.KEYS()(s): [A1].Resize(N, 8) = Crr
Next
'↑設順迴圈將以每個貨號新增工作表,將資料寫入工作表中
End Sub作者: Andy2483 時間: 2024-3-12 10:18
謝謝論壇,謝謝各位前輩
後學藉此帖練習陣列與字典另一方案,學習方案與心得如下,請各位前輩指教
Option Explicit
'這方案是以字典key記錄不重複的貨號,item為二維陣列,
'另以貨號連接"/r"字串為key,item為該二維陣列已使用的列數
Sub TEST_2()
Application.DisplayAlerts = False
Dim Brr, Crr(1 To 1000, 1 To 8), Z, Q, A, R&, i&, j%, s%, N%
Set Z = CreateObject("Scripting.Dictionary")
For Each A In Worksheets
If A.Name <> "總表" Then A.Delete
Next
Brr = [A1].CurrentRegion
For i = 3 To UBound(Brr)
A = Z(Brr(i, 2)): R = Z(Brr(i, 2) & "/r") + 1
'迴圈一開始:
'A = Z(Brr(i, 2))這程序執行就已經在Z字典裡產生了key是 Brr(i, 2)陣列值,
'而這對應item是空的,程序意義是令以A變數是 迴圈貨號為key將item二維陣列提取出來,
'如果item不是二維陣列也沒差!
'因為A變數宣告的是通用型變數,可以隨需求作變換(畢竟一開始的字典裡哪來的二維陣列)
If Not IsArray(A) Then A = Crr
'↑如果A變數不是陣列,就令A是同Crr變數的二維陣列
'至此每個i迴圈都以貨號當key,item是裝結果資料的二維陣列,貨號連接"/r"字串記錄該
'二維陣列用到哪一列了
For j = 1 To 8: A(R, j) = Brr(i, j): Next
Z(Brr(i, 2)) = A: Z(Brr(i, 2) & "/r") = R
Next
'↑藉著將二維陣列在item置入/提取/編輯/放回達到目的,至於為何要提取出來再編輯?
'VBA規則:字典裡的陣列要編輯需提取出來再放回,無法直接在字典裡編輯
For Each A In Z.keys
If Not IsArray(Z(A)) Then GoTo A01
Worksheets.Add.Name = A
[A1:H1].Resize(2) = Brr
[A3].Resize(Z(A & "/r"), 8) = Z(A)
A01: Next
'↑設逐項迴圈將字典裡的二維陣列寫入新增工作表裡
End Sub作者: Andy2483 時間: 2024-3-12 13:51
謝謝論壇,謝謝各位前輩
後學藉此帖練習陣列與字典,學習方案如下:
Option Explicit
'這方案是以字典key記錄不重複的貨號,item為儲存格集
Sub TEST_3()
Application.DisplayAlerts = False
Dim Brr, A, Z, Q, i&, T$
Set Z = CreateObject("Scripting.Dictionary")
For Each A In Worksheets
If A.Name <> "總表" Then A.Delete
Next
Brr = [A1].CurrentRegion
For i = 3 To UBound(Brr)
T = Brr(i, 2)
If Not IsObject(Z(T)) Then
Set Z(T) = Union([A1:A2], Cells(i, 2))
Else
Set Z(T) = Union(Z(T), Cells(i, 2))
End If
Next
For Each Q In Z.keys
Worksheets.Add.Name = Q
Z(Q).EntireRow.Copy [A1]
Next
End Sub
