回復 1#tony0318
純參考 另一種方式 使用 陣列
Sub Ex()
Dim Ar(), M$, A As Range, i%
ReDim Ar(0)
With Sheet1
Set Ar(0) = .Range("A1").Resize(1, 12)
M = .Range("C1")
For Each A In .Range(.[A2], .[A65536].End(xlUp))
If UBound(Filter(Split(M, ","), A(1, 3), True)) > -1 Then
i = Application.Match(A(1, 3), Split(M, ","), 0)
Set Ar(i - 1) = Union(Ar(i - 1), A.Resize(1, 12))
Else
M = M & "," & A(1, 3)
ReDim Preserve Ar(UBound(Ar) + 1)
Set Ar(UBound(Ar)) = Union(Ar(0), A.Resize(1, 12))
End If
Next
End With
On Error GoTo NewSheet
For i = 1 To UBound(Split(M, ","))
With Sheets(Split(M, ",")(i))
.Cells.Clear
Ar(i).Copy .Range("A1")
End With
Next
Sheet1.Activate
Exit Sub
NewSheet:
With Sheets.Add(after:=Sheets(Sheets.Count))
.Name = Split(M, ",")(i)
End With
Resume
End Sub作者: Andy2483 時間: 2022-10-14 09:48
Union收集資料在工作表裡:
[attach]35314[/attach]
Option Explicit
Sub Union_收集資料在工作表裡()
Dim Arr, i&, xR As Range
Set xR = Cells(1, "C").Offset(, -2).Resize(, 12)
For i = 2 To Cells(Rows.Count, "C").End(3).Row
If Cells(i, "C") = "A" Then
Set xR = Union(xR, Cells(i, "C").Offset(, -2).Resize(, 12))
End If
Next
Arr = xR
Workbooks.Add
xR.Copy [A1]
End Sub
Union收集資料在陣列裡再貼到表裡:
[attach]35315[/attach]
Option Explicit
Sub Union_收集資料在陣列裡再貼到表裡()
Dim Arr, i&, xR As Range
Set xR = Cells(1, "C").Offset(, -2).Resize(, 12)
For i = 2 To Cells(Rows.Count, "C").End(3).Row
If Cells(i, "C") = "A" Then
Set xR = Union(xR, Cells(i, "C").Offset(, -2).Resize(, 12))
End If
Next
Arr = xR
Workbooks.Add
[A1].Resize(UBound(Arr), UBound(Arr, 2)) = Arr
End Sub作者: Andy2483 時間: 2022-10-14 14:47
Sub 在陣列裡_收集資料再貼到表裡_不含格式()
Dim Arr(1 To 999, 1 To 12), i&, xR As Range, xD, x, y
Set xD = CreateObject("Scripting.Dictionary")
y = 1
For x = 1 To 12
Arr(1, x) = Cells(1, x)
Next
For Each xR In Range([C1], [C65536].End(xlUp))
If xR = "A" Then
y = y + 1
For x = 1 To 12
Arr(y, x) = Cells(xR.Row, x)
Next
End If
Next
xD(1) = Arr
Workbooks.Add
[A1].Resize(999, 12) = xD(1)
End Sub
Sub 在ITEM裡_收集資料再貼到表裡_會跑但是沒有資料()
Dim Arr(1 To 999, 1 To 12), i&, xR As Range, xD, x, y
Set xD = CreateObject("Scripting.Dictionary")
xD(1) = Arr
y = 1
For x = 1 To 12
xD(1)(1, x) = Cells(1, x)
Next
For Each xR In Range([C1], [C65536].End(xlUp))
If xR = "A" Then
y = y + 1
For x = 1 To 12
xD(1)(y, x) = Cells(xR.Row, x)
MsgBox xD(1)(y, x)
Next
End If
Next
Workbooks.Add
[A1].Resize(999, 12) = xD(1)
End Sub作者: Andy2483 時間: 2022-10-18 08:47
本帖最後由 Andy2483 於 2022-10-18 08:51 編輯
各位前輩好
今天練習陣列語字典
心得註解如下:
Option Explicit
Sub TEST()
Dim Arr, Brr(1 To 999, 1 To 12), Crr, c&, i&, x&, R&, T, Y, N, j, Z
'↑宣告變數
Set Y = CreateObject("Scripting.Dictionary")
'↑令Y是字典
Set Arr = [工作表1!A1].CurrentRegion
'↑令 Brr是 [A1]相鄰非空格所串連起來的儲存格,擴展到方正區域的最小範圍儲存格
c = [工作表1!A1].End(xlToRight).Column
'↑令C是此表的欄數
R = [工作表1!A1].End(xlDown).Row
'↑令R是此表的列數
For i = 2 To R
'↑設迴圈從2開始到此表的列數
T = Arr(i, 3)
'↑令T是 C欄項目名稱
Crr = Y(T & "|") '#1
'↑令Crr是Y字典裡的 項目名稱&"|"字串 為key的item
Y(T) = Y(T) + 1 '@1
'↑令項目名稱 為key,item累加1,這是後面用來指定陣列列數的
',如 @1 標註
If Not IsArray(Crr) Then
'↑如果判定 Crr 還不是陣列
Y(T) = Y(T) + 1
'↑令項目名稱 為key,item累加1,這是後面用來指定陣列列數的
',如 @2 標註!這裡+1是為了空出一列給標題列用的
Crr = Brr
'↑令Crr變成一個上述Brr(1 To 999, 1 To 12)空陣列
',所以Brr從頭到尾都是一個空的容器
End If
For j = 1 To 12
'設迴圈將資料帶入Crr陣列
Crr(Y(T), j) = Arr(i, j) '@1
If Y(T) = 2 Then '@2
'↑如果此時的陣列寫入是在第2列
Crr(1, j) = Arr(1, j)
'↑就一起把標題列寫進去陣列裡
End If
Next j
Y(T & "|") = Crr '#1
'↑令 項目名稱&"|"字串 為key ,令Crr為它的item,
Next
'↑迴圈總結:
'迴圈會讓字典裡裝進數字.字串.陣列
Workbooks.Add
For Each Z In Y.KEYS
'↑設順迴圈令Z是Y字典裡key的一員
If InStr(Z, "|") Then
'↑如果Z這key字串裡有 "|" 符號,代表他的item是陣列
'我們就是要調出陣列放在新工作表裡,如 #1 標註
Crr = Y(Z)
'↑用Crr 裝這Y(Z)陣列來看比較習慣!看到括弧()就害怕!
With Sheets.Add(after:=Sheets(Sheets.Count))
'↑在上方新開的活頁簿最後工作表後面再新開依工作表
.Name = Replace(Z, "|", "")
'↑工作表名是 項目名稱&"|"字串 去掉 "|" 符號
.[A1].Resize(UBound(Crr), UBound(Crr, 2)) = Crr
'↑把陣列從[A1]開始貼進儲存格裡了!
.[I:J].NumberFormatLocal = "yyyy/m/d"
'↑令[I:J]欄的格式是 西元4碼年 /能1碼就不要兩碼的月/日
.Cells.Columns.AutoFit
'↑令整表的所有欄位自動調整欄寬
End With
End If
Next
End Sub
懇請各位前輩指正並指導!
