123
返回列表 上一主題 發帖

關於寫巨集程式自動篩選判斷區的代碼複製成該代碼單獨活頁簿

c_c_lai

帖子
2035 
主題
24 
精華
0 
積分
2031 
點名
0  
作業系統
Win7 
軟體版本
Office2010 
閱讀權限
100 
性別
男 
註冊時間
2012-3-22 
最後登錄
2024-2-1 
21# 跳轉到 »
發表於 2016-2-25 09:39 | 只看該作者
回復 19# Hsieh
  1. Sub ex()                     '  Hsieh
  2.     Dim ar(0 To 1), ay(), txt$, rng As Range, cts As Integer
  3.    
  4.     Set d = CreateObject("Scripting.Dictionary")
  5.    
  6.     With Sheets("彙總表")
  7.         For Each a In .Range(.[B2], .[B2].End(xlDown))
  8.             If IsEmpty(d(a & "")) Then
  9.                 ar(0) = Array(.[B1], .[C1], .[D1], .[E1])
  10.                 ar(1) = Application.Transpose(Application.Transpose(a.Resize(, 4).Value))
  11.                 d(a & "") = ar      '  a & "" 即等於 CStr(a)。 將 a : Variant 轉換為 String 型態
  12.             Else
  13.                 ay = d(a & "")
  14.                 s = UBound(ay)
  15.                 ReDim Preserve ay(s + 1)
  16.                 ay(s + 1) = Application.Transpose(Application.Transpose(a.Resize(, 4).Value))
  17.                 d(a & "") = ay
  18.                 Erase ay
  19.             End If
  20.             '  d(CStr(a)) = Array(d(CStr(a)), a.Resize(, 4).Value)
  21.             '  a & "" 即等於 CStr(a)。 將 a : Variant 轉換為 String 型態
  22.         Next     '  d.Count = 3 : Variant/Long
  23.         
  24.         For Each sh In Sheets    '  sh : Variant/Object/工作表1/工作表8
  25.             If sh.Name <> "彙總表" And d.exists(sh.Name) = True Then
  26.                 ay = d(sh.Name)
  27.                
  28.                 '  sh.[B1].Resize(UBound(ay) + 1, 4) = Application.Transpose(Application.Transpose(ay))
  29.                 '  直行至上一行則產生 『執行階段： 13 「型態不符」』，故改以下列語法處裡：
  30.                 Set rng = sh.[B1]
  31.                 Sheets("彙總表").[B1:E1].Copy rng
  32.                 For cts = 1 To UBound(ay)
  33.                     rng.Offset(cts).Resize(1, 4) = Application.Transpose(Application.Transpose(ay(cts)))
  34.                 Next cts
  35.                 d.Remove sh.Name
  36.             End If
  37.         Next               '  d.Count = 0 : Variant/Long
  38.         
  39.         For Each ky In d.keys
  40.             With Sheets.Add(after:=Sheets(Sheets.Count))
  41.                 .Name = ky
  42.                 ay = d(ky)
  43.                
  44.                 '  .[B1].Resize(UBound(ay) + 1, 4) = Application.Transpose(Application.Transpose(ay))
  45.                 '  直行至上一行則產生 『執行階段： 13 「型態不符」』，故改以下列語法處裡：
  46.                 Set rng = .[B1]
  47.                 Sheets("彙總表").[B1:E1].Copy rng
  48.                 For cts = 1 To UBound(ay)
  49.                     rng.Offset(cts).Resize(1, 4) = Application.Transpose(Application.Transpose(ay(cts)))
  50.                 Next cts
  51.             End With
  52.         Next
  53.     End With
  54. End Sub
複製代碼

TOP

c_c_lai

帖子
2035 
主題
24 
精華
0 
積分
2031 
點名
0  
作業系統
Win7 
軟體版本
Office2010 
閱讀權限
100 
性別
男 
註冊時間
2012-3-22 
最後登錄
2024-2-1 
22#
發表於 2016-2-26 13:06 | 只看該作者
回復 19# Hsieh
終於抓到問題癥結了，連夢睡中也在捺悶。
  1. ar(0) = Array(.[B1], .[C1], .[D1], .[E1])
複製代碼
.[B1] 傳入的是 Range 物件，而非字串； 故會造成 『執行階段： 13 「型態不符」』，故改以下列語法處裡：
  1. ar(0) = Array(.[B1].Value & "", .[C1].Value, .[D1].Value, .[E1].Value)
複製代碼
其它內容維持不變。
  1. Sub ex()                     '  Hsieh
  2.     Dim ar(0 To 1), ay()
  3.    
  4.     Set d = CreateObject("Scripting.Dictionary")
  5.    
  6.     With Sheets("彙總表")
  7.         For Each a In .Range(.[B2], .[B2].End(xlDown))
  8.             If IsEmpty(d(a & "")) Then
  9.                 '  ar(0) = Array(.[B1], .[C1], .[D1], .[E1])
  10.                 '  .[B1] 傳入的是 Range 物件，而非字串； 故會造成 『執行階段： 13 「型態不符」』，故改以下列語法處裡：
  11.                 ar(0) = Array(.[B1].Value & "", .[C1].Value, .[D1].Value, .[E1].Value)
  12.                 ar(1) = Application.Transpose(Application.Transpose(a.Resize(, 4).Value))
  13.                 d(a & "") = ar      '  a & "" 即等於 CStr(a)。 將 a : Variant 轉換為 String 型態
  14.             Else
  15.                 ay = d(a & "")
  16.                 s = UBound(ay)
  17.                 ReDim Preserve ay(s + 1)
  18.                 ay(s + 1) = Application.Transpose(Application.Transpose(a.Resize(, 4).Value))
  19.                 d(a & "") = ay
  20.                 Erase ay
  21.             End If
  22.         Next
  23.         
  24.         For Each sh In Sheets  
  25.             If d.exists(sh.Name) = True Then
  26.                 ay = d(sh.Name)
  27.                 sh.Cells.Clear
  28.                
  29.                 sh.[B1].Resize(UBound(ay) + 1, 4) = Application.Transpose(Application.Transpose(ay))
  30.                 d.Remove sh.Name
  31.             End If
  32.         Next               '  d.Count = 0 : Variant/Long
  33.         
  34.         For Each ky In d.keys
  35.             With Sheets.Add(after:=Sheets(Sheets.Count))
  36.                 .Name = ky
  37.                 ay = d(ky)
  38.                
  39.                 .[B1].Resize(UBound(ay) + 1, 4) = Application.Transpose(Application.Transpose(ay))
  40.             End With
  41.         Next
  42.     End With
  43. End Sub
複製代碼

TOP

千暉尋

帖子
36 
主題
7 
精華
0 
積分
77 
點名
0  
作業系統
WIN7 
軟體版本
MICROSOFT 
閱讀權限
20 
註冊時間
2015-6-7 
最後登錄
2024-9-22 

論壇榮譽勳章論壇贊助勳章
23#
發表於 2016-2-26 22:34 | 只看該作者
回復 13# 准提部林
請問准大,第1次及第2次迴圈都是碰到相同的A這個值,理解如下:
第1次(A,香蕉..)迴圈時,就篩選所有A的資料及貼在一個名稱為A的工作表(新增的表),第2次迴圈時碰到(A,鳳梨..)時,仍會重做工作表命名(即便原來名稱就叫A,改名後仍是叫A,但少了新增工作表的動作),及清除工作表A的先前的內容,底下的語法再重作篩選及後續貼上篩選結果的動作(即便第2次的結果和第1次都會是相同的),不知道對不對!

TOP

千暉尋

帖子
36 
主題
7 
精華
0 
積分
77 
點名
0  
作業系統
WIN7 
軟體版本
MICROSOFT 
閱讀權限
20 
註冊時間
2015-6-7 
最後登錄
2024-9-22 

論壇榮譽勳章論壇贊助勳章
24#
發表於 2016-2-26 22:54 | 只看該作者
拍謝!因為不小心鑽進死巷,沒有宏觀全部語句,問了一個笨問題,原來InStr(TT & "/", "/" & T & "/") Then GoTo 101這句語法就能避開重覆值的作用.

TOP

准提部林

帖子
2839 
主題
10 
精華
0 
積分
2895 
點名
0  
作業系統
〔略〕 
軟體版本
〔略〕 
閱讀權限
100 
性別
男 
來自
〔略〕 
註冊時間
2013-5-13 
最後登錄
2025-2-15 
25#
發表於 2016-2-27 10:11 | 只看該作者
回復 24# 千暉尋


哈！這是加深記憶的方法，
學vba，從錯誤中去修正，是好方法的！！！

TOP

c_c_lai

帖子
2035 
主題
24 
精華
0 
積分
2031 
點名
0  
作業系統
Win7 
軟體版本
Office2010 
閱讀權限
100 
性別
男 
註冊時間
2012-3-22 
最後登錄
2024-2-1 
26#
發表於 2016-2-27 10:28 | 只看該作者
回復 24# 千暉尋
這是我的作業心得報告，或許能幫助你進一步之了解，
將它貼上提供參考，在此篇議題中我覺得准大的解題
申論非常之棒，單刀切入直接了當，一揪即成。
在此亦感謝 准提部林版大 的不吝指導。
  1. '  篩選法！！！      准提部林
  2. '  使用此方法 "彙總表" 之初始內容不須先行排序 (Sorting)，亦即在保持原始狀況下直接進行篩選處裡
  3. Sub ex2()
  4.     Dim xArea As Range, i&, T$, TT$, Sht As Worksheet
  5.    
  6.     With Sheets("彙總表")
  7.         .Select
  8.         Set xArea = .Range([B1], Cells(Rows.Count, "B").End(xlUp)(1, 4))
  9.         '  xArea : Range/Range  :  xArea.Address = "$B$1:$E$7" :  String
  10.     End With
  11.    
  12.     For i = 2 To xArea.Rows.Count         '  xArea.Rows.Count : 7 : Long,  xArea.DataSeries : True : Variant/Boolean
  13.         T = xArea(i, 1): Set Sht = Nothing           '  i = 2 : Long
  14.         '  -------------------------------------------------------------------------
  15.         '  為觀察 InStr(TT & "/", "/" & T & "/") 以及 TT = TT & "/" & T 的處理方式，
  16.         '  特將 "彙總表" 內容之順序事先預作調整如下，以方便偵測 TT 過程中扮演的角色。
  17.         '  -------------------------------------------------------------------------
  18.         '  2(i) : xArea(i, 1) = "A" :  xArea(i, 2) = "香蕉" :  xArea(i, 3) = 10 :  xArea(i, 4) = 100 : Variant/Object/Range
  19.         '  3(i) : xArea(i, 1) = "B" :  xArea(i, 2) = "青椒" :  xArea(i, 3) = 50 :  xArea(i, 4) = 500 : Variant/Object/Range
  20.         '  4(i) : xArea(i, 1) = "A" :  xArea(i, 2) = "葡萄" :  xArea(i, 3) = 30 :  xArea(i, 4) = 300 : Variant/Object/Range
  21.         '  5(i) : xArea(i, 1) = "B" :  xArea(i, 2) = "鳳梨" :  xArea(i, 3) = 40 :  xArea(i, 4) = 400 : Variant/Object/Range
  22.         '  6(i) : xArea(i, 1) = "C" :  xArea(i, 2) = "芭樂" :  xArea(i, 3) = 60 :  xArea(i, 4) = 600 : Variant/Object/Range
  23.         '  7(i) : xArea(i, 1) = "A" :  xArea(i, 2) = "蘋果" :  xArea(i, 3) = 20 :  xArea(i, 4) = 200 : Variant/Object/Range
  24.         
  25.         If T = "" Or InStr(TT & "/", "/" & T & "/") Then GoTo 101
  26.         '  ----------------------------------------------------------------------------------------------
  27.         '  2(i) : TT & "/" = "/" : "/" & T & "/" = "/A/" : InStr(TT & "/", "/" & T & "/")           = 0 : Long
  28.         '  3(i) : TT & "/" = "/A" : "/" & T & "/" = "/B/" : InStr(TT & "/", "/" & T & "/")         = 0 : Long
  29.         '  4(i) : TT & "/" = "/A/B" : "/" & T & "/" = "/A/" : InStr(TT & "/", "/" & T & "/")     = 1 : Long
  30.         '  5(i) : TT & "/" = "/A/B" : "/" & T & "/" = "/B/" : InStr(TT & "/", "/" & T & "/")     = 1 : Long
  31.         '  6(i) : TT & "/" = "/A/B" : "/" & T & "/" = "/C/" : InStr(TT & "/", "/" & T & "/")     = 0 : Long
  32.         '  7(i) : TT & "/" = "/A/B/C" : "/" & T & "/" = "/A/" : InStr(TT & "/", "/" & T & "/") = 1 : Long
  33.         '  ----------------------------------------------------------------------------------------------
  34.         '  InStr(TT & "/", "/" & T & "/") 的意思為當第一次讀取過的工作表名稱會寫入到變數 TT 的字串中,
  35.         '  因為已經做過篩選了, 所以當再次讀取到曾記錄過的名稱時跳過, 而 "/"  則是要區分各工作表名的區隔，
  36.         '  不會重覆，讓 InStr 容易判斷，而不會產生錯誤的判斷；
  37.         '  InStr(TT & "/", "/" & T & "/")　用 "/' 分隔可以清楚分別 A, AA, AAA 或 A1, A11, A111，而不會誤判！
  38.         '  而且理論上, 工作表名稱不會有 "/" 字元，若用其它符號，就要考慮工作表表名稱是否含有這個符號，
  39.         '  例如： 用 "-" 分隔，就可能對 1-1, 1-11, 1-111  造成相似工作表名稱之誤判！！
  40.         '  ----------------------------------------------------------------------------------------------
  41.         On Error Resume Next
  42.         
  43.         Set Sht = Sheets(T)
  44.         On Error GoTo 0
  45.         
  46.         If Sht Is Nothing Then Set Sht = Sheets.Add(after:=Sheets(Sheets.Count)): Sht.Name = T   '  Sht 不存在
  47.         Sht.UsedRange.Clear
  48.         
  49.         With xArea
  50.             .Parent.Select     ' xArea.Parent.Name = "彙總表" : Variant/String
  51.             .AutoFilter Field:=1, Criteria1:=T   ' T = "A" : T = "B" :  T = "C" : String
  52.             '  AutoFilter 會依據 Criteria1 的條件匯集，標題位置並不會異動
  53.             .Copy Sht.[B1]                 '  包含標題與內容一一複製到 "A"、"B"、"C" 各別的工作表單內
  54.         End With
  55.         
  56.         TT = TT & "/" & T       '  TT = "/A" : TT = "/A/B" :  TT = "/A/B/C" ： String  (判斷字串 TT 逐一增加)
  57. 101:
  58.     Next i
  59.    
  60.     ActiveSheet.AutoFilterMode = False         '  回復到原始最初的 "彙總表" 之排序前內容順序
  61. End Sub
複製代碼
1

評分人數

TOP

千暉尋

帖子
36 
主題
7 
精華
0 
積分
77 
點名
0  
作業系統
WIN7 
軟體版本
MICROSOFT 
閱讀權限
20 
註冊時間
2015-6-7 
最後登錄
2024-9-22 

論壇榮譽勳章論壇贊助勳章
27#
發表於 2016-2-27 11:13 | 只看該作者
回復 26# c_c_lai
感謝C_C_LAI大大提供詳盡的筆記,這樣更能清楚准大的語法精妙所在!

TOP

c_c_lai

帖子
2035 
主題
24 
精華
0 
積分
2031 
點名
0  
作業系統
Win7 
軟體版本
Office2010 
閱讀權限
100 
性別
男 
註冊時間
2012-3-22 
最後登錄
2024-2-1 
28#
發表於 2016-2-28 08:22 | 只看該作者
回復 27# 千暉尋
另一種撰寫方式： 不使用 GoTo 101 的方法
因早期在撰寫八位元、及十六位元程式時
(包含 Digital Research 的 CBasic)，幾乎
盡量避免去使用  GoTo Syntax，我利用准大
的現成程式來改寫成如下，請參考使用方式：
  1.     For i = 2 To xArea.Rows.Count
  2.         T = xArea(i, 1): Set Sht = Nothing
  3.         
  4.         '  If T = "" Or InStr(TT & "/", "/" & T & "/") Then GoTo 101
  5.         If T <> "" And InStr(TT & "/", "/" & T & "/") = 0 Then
  6.             '
  7.             '
  8.             '
  9.             '
  10.             '
  11.             '
  12.             TT = TT & "/" & T
  13.         End If   '  直接使用 If Then ~ End If 的處理模式
  14. '  101:          '  將它改成附註
  15.     Next i
複製代碼

TOP

        靜思自在 : 太陽光大、父母恩大、君子量大，小人氣大。
123
返回列表 上一主題