請測試看看，謝謝
Sub test()
Dim Arr, Brr, xD, xD1, TT, n%, C%, m%, i&, k%
Set xD = CreateObject("Scripting.Dictionary")
Set xD1 = CreateObject("Scripting.Dictionary")
Arr = Range([資料!c1], [資料!a65536].End(3))
For i = 2 To UBound(Arr)
If Arr(i, 2) = "" Then GoTo 99
If Not xD.Exists(Arr(i, 2) & "") Then
k = k + 1: xD(Arr(i, 2) & "") = k
End If
99: Next
ReDim Brr(1 To UBound(Arr), 1 To xD.Count + 1)
With Sheets("呈現表")
.Range("b1").Resize(, xD.Count) = xD.keys
For i = 2 To UBound(Arr)
C = xD(Arr(i, 2) & "") + 1
If xD1.Exists(Arr(i, 1)) Then
m = xD1(Arr(i, 1))
If IsEmpty(Brr(m, C)) Then Brr(m, C) = Arr(i, 3) Else Brr(m, C) = Brr(m, C) & "," & Arr(i, 3)
Else
n = n + 1: xD1(Arr(i, 1)) = n
Brr(n, 1) = Arr(i, 1): Brr(n, C) = Arr(i, 3)
End If
Next
.Range("a2").Resize(n, xD.Count) = Brr
End With
End Sub作者: hcm19522 時間: 2021-11-1 14:25
Sub 單筆資料()
Dim Arr, Brr, Crr(1 To 1, 1 To 100), xD, xD1, m%, m0%, m1%
Dim k0%, k1%, k%, ky, CMax, T$, n%, C%, C1%, i&
Set xD = CreateObject("Scripting.Dictionary")
Set xD1 = CreateObject("Scripting.Dictionary")
With Sheets("資料")
With .Range(.[C1], .[a65536].End(xlUp))
Brr = .Value
.Sort Key1:=.Item(1), Order1:=xlAscending, _
Key2:=.Item(2), Order2:=xlAscending, Header:=xlYes
Arr = .Value
.Value = Brr
End With
End With
For i = 2 To UBound(Arr)
If Arr(i, 2) = "" Then GoTo 97
T = Arr(i, 1) & "_" & Arr(i, 2)
If Not xD.Exists(T) Then '取欄數
xD(Arr(i, 2) & "") = 1: xD(T) = ""
Else
k0 = xD(Arr(i, 2) & ""): k1 = xD1(Arr(i, 2) & "")
If k0 > k1 Then k = k0 + 1 Else k = k1 + 1
xD1(Arr(i, 2) & "") = k
End If
97: Next
For Each ky In xD.keys '列出第一列表頭
If InStr(ky, "_") Then GoTo 98
If xD1.Exists(ky) Then
For j = 1 To xD1(ky): y = y + 1: Crr(1, y) = ky: Next
Else
y = y + 1: Crr(1, y) = ky: s = s + 1
End If
98: Next
xD1.RemoveAll
ReDim Brr(1 To UBound(Arr), 1 To y + 1)
With Sheets("呈現表")
.[a1:aa100] = ""
.Range("b1").Resize(, y) = Crr
For i = 2 To UBound(Arr)
If Arr(i, 2) = "" Then GoTo 99
C = Application.WorksheetFunction.Match(Arr(i, 2), Sheets(2).Range("a1").Resize(, y + 1), 0)
If xD1.Exists(Arr(i, 1)) Then
m = xD1(Arr(i, 1))
If IsEmpty(Brr(m, C)) Then
Brr(m, C) = Arr(i, 3)
Else
If m0 = 0 Then m0 = m
If m0 <> m Then C1 = 0
If C1 > C Then C1 = C1 + 1 Else C1 = C + 1
Brr(m, C1) = Arr(i, 3)
End If
Else
n = n + 1: xD1(Arr(i, 1)) = n
Brr(n, 1) = Arr(i, 1): Brr(n, C) = Arr(i, 3)
End If
99: Next
.Range("a2").Resize(n, y + 1) = Brr
End With
End Sub作者: 准提部林 時間: 2021-11-6 19:01
以下心得註解請前輩再指教!謝謝前輩
Sub TEST_A1()
Dim Arr, Brr, xD, T$(3), i&, j%, R&, C%, X&, Y%
'↑宣告變數,批次宣告T是字串變數 T(0)~T(3)
Call 清除
'↑執行副程式 清除()
Set xD = CreateObject("Scripting.Dictionary")
'↑令 xD是字典
Arr = Range([資料!c1], [資料!a1].Cells(Rows.Count, 1).End(xlUp))
'↑令 Arr是陣列,倒入 資料表裡C1到A欄最後一個有內容儲存格
'這兩個儲存格間擴展到最小方正區域儲存格的值
ReDim Brr(1 To UBound(Arr), 1 To 200)
'↑宣告 Brr陣列的範圍! 縱向是1 到 Arr陣列的列數
'橫向是1 到 200 欄數
For i = 2 To UBound(Arr)
'↑設外順迴圈 從2 到 Arr陣列最後列數
For j = 1 To 3
'↑設內順迴圈 從1 到3
T(j) = Arr(i, j)
'↑令迴圈中 T字串變數裝入Arr陣列對應值
If T(j) = "" Then
'↑如果 此內迴圈中 T字串變數 裝入了空格
GoTo 101
'↑條件成立!就跳到 101 繼續執行
End If
Next j
T(0) = T(2) & "|" & Format(T(3), "0000")
'↑令第1個T字串變數是 第3個T字串變數 & "|" & 第4個T字串(4碼數字)
X = xD(T(1))
'↑令X數字變數是 xD字典裡以 第2個T字串 值為key的item
'一開始是查不到 item!但是字典裡已經收納了 第2個T字串 值為key
'因為X數字變數!查不到就是初始值0
Y = xD(T(0))
'↑令Y數字變數是 xD字典裡以 第1個T字串 值為key的item
'一開始也是查不到 item!但是字典裡已經收納了 第1個T字串 值為key
'因為Y數字變數!查不到就是初始值0
If X = 0 Then
'↑如果X數字變數是初始值0
R = R + 1
'↑條件成立!R數字變數就累加 1
X = R + 1
'↑條件成立!X數字變數又以R數字變數再 +1
'因為標題欄是從往下第2個開始
xD(T(1)) = X
'↑令 xD字典中 第2個T字串變數(編號) 為key的item = X數字變數
'所以開始裝入的item是 數字2
Brr(X, 1) = T(1)
'↑一開始是令Brr陣列第2列第1欄是 第2個T字串變數(編號)
'↑這是標題欄
End If
If Y = 0 Then
'↑如果Y數字變數是初始值0
C = C + 1
'↑條件成立!C數字變數就累加 1
Y = C + 1
'↑條件成立!Y數字變數又以C數字變數再 +1
'因為標題列是從往右第2個開始
xD(T(0)) = Y
'↑令 xD字典中 (原料)& "|" &(批號) 為key的item = Y數字變數
Brr(1, Y) = T(0)
'↑一開始是令Brr陣列第1列第2欄是 第1個T字串變數 (原料)& "|" &(批號)
'↑這是標題列
End If
Brr(X, Y) = T(3)
'↑標題列欄所對應的 批號放入 Brr陣列中
101: Next i
Brr(1, 1) = " 原料 編號"
'↑令Brr陣列第1列第1欄儲存格的字串
With [呈現表!A1].Resize(R + 1, C + 1)
'↑R是不包含標題列!所以要 +1 ,C是不包含標題欄!所以要 +1
.Value = Brr
'↑將Brr陣列從 呈現表[A1]貼入值
.Columns(2).Resize(, C).Sort Key1:=.Cells(1, 2), Order1:=xlAscending, Header:=xlNo, Orientation:=xlLeftToRight
'↑欄以標題列排序
.Rows(2).Resize(R).Sort Key1:=.Cells(2, 1), Order1:=xlAscending, Header:=xlNo, Orientation:=xlTopToBottom
'↑列以標題欄排序
.Rows(1).Replace "|*", "", Lookat:=xlPart
'↑把標題列去除 "|"符號(含)右邊的字元!標題列剩下 (原料)
.Borders.LineStyle = 1
'↑讓儲存格格線顯示 細實線
End With
End Sub
Sub 清除()
With Sheets("呈現表").UsedRange
.Offset(1, 0).EntireRow.Delete
.Offset(, 1).EntireColumn.Delete
'留下[A1]儲存格!其餘儲存格刪除
End With
End Sub作者: Andy2483 時間: 2022-10-28 13:48
Option Explicit
Sub TEST_20221028()
Dim Arr, i&, j&, T1, T2, T3, W, X, Y, Z, C, R
Arr = Range([資料!c1], [資料!a1].Cells(Rows.Count, 1).End(xlUp))
Set X = CreateObject("Scripting.Dictionary")
Set Y = CreateObject("Scripting.Dictionary")
Set W = CreateObject("Scripting.Dictionary")
For i = 2 To UBound(Arr)
T1 = Arr(i, 1)
T2 = Arr(i, 2)
T3 = Format(Arr(i, 3), "0000")
Y(T1) = ""
X(T2 & "|" & T3) = ""
W(T1 & "|" & T2 & "|" & T3) = T3
Next
ReDim Arr(1 To Y.Count + 1, 1 To X.Count + 1)
i = 1
For Each R In Y.KEYS
i = i + 1
Arr(i, 1) = R
j = 1
For Each C In X.KEYS
j = j + 1
Arr(i, j) = W(R & "|" & C)
Arr(1, j) = IIf(i = 2, C, Arr(1, j))
Next
Next
Arr(1, 1) = " 原料 編號"
With [呈現表!A1].Resize(UBound(Arr), UBound(Arr, 2))
.Value = Arr
.Columns(2).Resize(, UBound(Arr, 2)).Sort Key1:=.Cells(1, 2), Order1:=xlAscending, Header:=xlNo, Orientation:=xlLeftToRight
.Rows(2).Resize(UBound(Arr)).Sort Key1:=.Cells(2, 1), Order1:=xlAscending, Header:=xlNo, Orientation:=xlTopToBottom
.Rows(1).Replace "|*", "", Lookat:=xlPart
.Borders.LineStyle = 1
End With
End Sub
