Option Explicit
Sub TEST()
Dim Brr, Crr(1 To 1000, 1 To 3), A, V, Z, K, i&, N&, R&, X&, T$, T3$, T4$, xR As Range
Set Z = CreateObject("Scripting.Dictionary")
Application.Goto [底稿!H1:O1]
[I:O].Delete
Brr = Range([E1], [B65536].End(3)(1, 0))
For i = 2 To UBound(Brr)
T3 = Brr(i, 3)
V = Val(Brr(i, 5))
T4 = Brr(i, 4)
If T3 = "套件父項" Then
T = T4
If Not Z.Exists(T) Then
Z(T) = Crr
A = Crr
N = N + 1
Z(T & "/") = N
Brr(N, 1) = T
Brr(N, 2) = V
Else
A = Z(T)
Brr(Z(T & "/"), 2) = Brr(Z(T & "/"), 2) + V
End If
GoTo i01
End If
R = Z(T & "/" & T4)
If R = 0 Then
Z(T & "|") = Z(T & "|") + 1
A(Z(T & "|"), 1) = T4
A(Z(T & "|"), 2) = T
Z(T & "/" & T4) = Z(T & "|")
R = Z(T & "|")
End If
A(R, 3) = A(R, 3) + V
Z(T) = A
i01: Next
Set xR = [I2]
For Each K In Z.Keys
If IsArray(Z(K)) Then
xR.Resize(Z(K & "|"), 3) = Z(K)
Set xR = xR(Z(K & "|") + 1)
X = X + Z(K & "|")
End If
Next
With [H2].Resize(X, 4)
.Sort KEY1:=.Item(2), Order1:=1, Key2:=.Item(3), Order2:=1, Header:=2
.Columns(1) = "=""套料"" &COUNTIF($I$2:I2,I2)"
End With
[H1:O1] = Array("套料", "套件子項", "套件父項", "實發數量", , , "套件父項", "實發數量")
With [N2].Resize(N, 2)
.Value = Brr
.Sort KEY1:=.Item(1), Order1:=1, Header:=2
End With
[H:O].Columns.AutoFit
End Sub作者: Andy2483 時間: 2025-8-22 16:12
謝謝論壇,謝謝各位前輩
以下是練習從字典中提取資料到新增註解的方案,請各位前輩指教
執行結果:
[attach]38077[/attach]
Option Explicit
Sub TEST1()
Dim Brr, Crr(1 To 1000, 1 To 5), A, V, Z, K, i&, N&, R&, X&, T$, T1$, T2$, T3$, T4$, xR As Range
Set Z = CreateObject("Scripting.Dictionary")
Application.Goto [底稿!H1:O1]
[I:O].Delete
Brr = Range([E1], [B65536].End(3)(1, 0))
For i = 2 To UBound(Brr)
T1 = Format(Brr(i, 1), "YYYY/MM/DD"): T2 = Brr(i, 2): T3 = Brr(i, 3)
V = Val(Brr(i, 5))
T4 = Brr(i, 4)
If T3 = "套件父項" Then
T = T4
If Not Z.Exists(T) Then
Z(T) = Crr: A = Crr
N = N + 1: Z(T & "/") = N
Brr(N, 1) = T: Brr(N, 2) = V
Else
A = Z(T)
Brr(Z(T & "/"), 2) = Brr(Z(T & "/"), 2) + V
End If
GoTo i01
End If
R = Z(T & "/" & T4)
If R = 0 Then
Z(T & "|") = Z(T & "|") + 1
A(Z(T & "|"), 1) = T4
A(Z(T & "|"), 2) = T
Z(T & "/" & T4) = Z(T & "|")
Z(T & "/" & T4 & "//") = "日期 單據編號 產品類型 物料編碼 實發數量"
R = Z(T & "|")
End If
A(R, 3) = A(R, 3) + V
Z(T) = A
Z(T & "/" & T4 & "//") = Z(T & "/" & T4 & "//") & vbLf & Join(Array(T1, T2, T3, T4, V), "__")
i01: Next
Set xR = [I2]
For Each K In Z.Keys
If IsArray(Z(K)) Then
xR.Resize(Z(K & "|"), 3) = Z(K)
Set xR = xR(Z(K & "|") + 1)
X = X + Z(K & "|")
End If
Next
With [H2].Resize(X, 4)
.Sort KEY1:=.Item(2), Order1:=1, Key2:=.Item(3), Order2:=1, Header:=2
.Columns(1) = "=""套料"" &COUNTIF($I$2:I2,I2)"
For i = 1 To X
T = Z(.Cells(i, 3) & "/" & .Cells(i, 2) & "//")
With .Cells(i, 2).AddComment
.Text Text:=T
.Shape.TextFrame.Characters.Font.Size = 12
.Shape.DrawingObject.AutoSize = True
End With
Next
End With
[H1:O1] = Array("套料", "套件子項", "套件父項", "實發數量", , , "套件父項", "實發數量")
With [N2].Resize(N, 2)
.Value = Brr
.Sort KEY1:=.Item(1), Order1:=1, Header:=2
End With
[H:O].Columns.AutoFit
End Sub
