[發問] 請求 自動依欄位分類巨集 修改

　暱稱: 厚臉皮的學生

帖子: 1446
主題: 40
精華: 0
積分: 1470
點名: 0
作業系統: Windows 7
軟體版本: Excel 2010 & 2016
閱讀權限: 50
性別: 男
來自: 台灣
註冊時間: 2020-7-15
最後登錄: 2024-11-28

8^#

發表於 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
懇請各位前輩指正並指導!

　暱稱: 厚臉皮的學生

帖子: 1446
主題: 40
精華: 0
積分: 1470
點名: 0
作業系統: Windows 7
軟體版本: Excel 2010 & 2016
閱讀權限: 50
性別: 男
來自: 台灣
註冊時間: 2020-7-15
最後登錄: 2024-11-28

7^#

發表於 2022-10-14 14:47 | 只看該作者

本帖最後由 Andy2483 於 2022-10-14 14:52 編輯

回復 2# Hsieh

前輩你好!
後學駑鈍!沒有正統學習,都以先入為主的方式學習!
所以常常都是錯中學,遇到挫折再慢慢推敲,為什麼會錯?
花很多時間研究各種情境用自己認為對的技巧試試看!
學得很慢!運用前輩們的帖子學習!如有冒犯請見諒!

後學一開始的學習前輩範例的心得就錯了!
## 設迴圈以儲存格值為KEY,放標題列進入item陣列,放入字典 ##
放標題列進入item的是物件(儲存格)

把原始資料部分儲存格加黃底色:

前輩的範例會連同格式一起 COPY 到新工作表:

後學先入為主以為放進字典的一定是陣列
後來才發現放在字典裡的陣列是要呼叫出來才能倒進資料
而且沒有格式
以下是後學研究的心得:

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

2022-10-14_141313.JPG (40.98 KB)

　暱稱: 厚臉皮的學生

帖子: 1446
主題: 40
精華: 0
積分: 1470
點名: 0
作業系統: Windows 7
軟體版本: Excel 2010 & 2016
閱讀權限: 50
性別: 男
來自: 台灣
註冊時間: 2020-7-15
最後登錄: 2024-11-28

6^#

發表於 2022-10-14 11:34 | 只看該作者

回復 2# Hsieh

謝謝前輩
忘了A是物件! 字典key要是數字或字串
A & "" = A.Value

練習時發現:
不連續的儲存格可以被收集起來放入工作表中
但是如果裝到陣列裡就會只裝第一段資料!後面的儲存格不會進去!
原始資料:

Union收集資料在工作表裡:

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收集資料在陣列裡再貼到表裡:

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

　暱稱: 厚臉皮的學生

帖子: 1446
主題: 40
精華: 0
積分: 1470
點名: 0
作業系統: Windows 7
軟體版本: Excel 2010 & 2016
閱讀權限: 50
性別: 男
來自: 台灣
註冊時間: 2020-7-15
最後登錄: 2024-11-28

5^#

發表於 2022-10-14 09:48 | 只看該作者

回復 2# Hsieh

謝謝前輩
請教前輩:
If IsEmpty(d(A & "")) Then
為什麼要加入一個空字元?

今天習得:
IsEmpty是用來判定變數是否初始化
設迴圈以儲存格值為KEY,放標題列進入item陣列,放入字典
逐列利用Union放入相同key的整列資料到item陣列裡
迴圈跑完後!字典裡的item陣列調出來放在新增的工作表裡

GBKEE

超級版主 Rank: 8 Rank: 8

帖子: 5923
主題: 13
精華: 1
積分: 5986
點名: 0
作業系統: win10
軟體版本: Office 2010
閱讀權限: 150
性別: 男
來自: 台灣基隆
註冊時間: 2010-5-1
最後登錄: 2022-1-23

2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章 2011兔年全勤獎章

4^#

發表於 2010-5-26 17:50 | 只看該作者

回復 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

tony0318

小學生 Rank: 1

帖子: 16
主題: 5
精華: 0
積分: 29
點名: 0
作業系統: WIN XP PRO
軟體版本: EXCEL 2003
閱讀權限: 10
註冊時間: 2010-5-5
最後登錄: 2014-8-15

3^#

發表於 2010-5-24 16:14 | 只看該作者

謝謝！

好像有點眉目了！！