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

帖子: 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，我利用准大
的現成程式來改寫成如下，請參考使用方式：

For i = 2 To xArea.Rows.Count
T = xArea(i, 1): Set Sht = Nothing
' If T = "" Or InStr(TT & "/", "/" & T & "/") Then GoTo 101
If T <> "" And InStr(TT & "/", "/" & T & "/") = 0 Then
'
'
'
'
'
'
TT = TT & "/" & T
End If ' 直接使用 If Then ~ End If 的處理模式
' 101: ' 將它改成附註
Next i

複製代碼

千暉尋

中學生 Rank: 2

帖子: 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大大提供詳盡的筆記,這樣更能清楚准大的語法精妙所在!

帖子: 2035
主題: 24
精華: 0
積分: 2031
點名: 0
作業系統: Win7
軟體版本: Office2010
閱讀權限: 100
性別: 男
註冊時間: 2012-3-22
最後登錄: 2024-2-1

26^#

發表於 2016-2-27 10:28 | 只看該作者

回復 24# 千暉尋
這是我的作業心得報告，或許能幫助你進一步之了解，
將它貼上提供參考，在此篇議題中我覺得准大的解題
申論非常之棒，單刀切入直接了當，一揪即成。
在此亦感謝准提部林版大的不吝指導。

' 篩選法！！！准提部林
' 使用此方法 "彙總表" 之初始內容不須先行排序 (Sorting)，亦即在保持原始狀況下直接進行篩選處裡
Sub ex2()
Dim xArea As Range, i&, T$, TT$, Sht As Worksheet
With Sheets("彙總表")
.Select
Set xArea = .Range([B1], Cells(Rows.Count, "B").End(xlUp)(1, 4))
' xArea : Range/Range : xArea.Address = "$B$1:$E$7" : String
End With
For i = 2 To xArea.Rows.Count ' xArea.Rows.Count : 7 : Long, xArea.DataSeries : True : Variant/Boolean
T = xArea(i, 1): Set Sht = Nothing ' i = 2 : Long
' -------------------------------------------------------------------------
' 為觀察 InStr(TT & "/", "/" & T & "/") 以及 TT = TT & "/" & T 的處理方式，
' 特將 "彙總表" 內容之順序事先預作調整如下，以方便偵測 TT 過程中扮演的角色。
' -------------------------------------------------------------------------
' 2(i) : xArea(i, 1) = "A" : xArea(i, 2) = "香蕉" : xArea(i, 3) = 10 : xArea(i, 4) = 100 : Variant/Object/Range
' 3(i) : xArea(i, 1) = "B" : xArea(i, 2) = "青椒" : xArea(i, 3) = 50 : xArea(i, 4) = 500 : Variant/Object/Range
' 4(i) : xArea(i, 1) = "A" : xArea(i, 2) = "葡萄" : xArea(i, 3) = 30 : xArea(i, 4) = 300 : Variant/Object/Range
' 5(i) : xArea(i, 1) = "B" : xArea(i, 2) = "鳳梨" : xArea(i, 3) = 40 : xArea(i, 4) = 400 : Variant/Object/Range
' 6(i) : xArea(i, 1) = "C" : xArea(i, 2) = "芭樂" : xArea(i, 3) = 60 : xArea(i, 4) = 600 : Variant/Object/Range
' 7(i) : xArea(i, 1) = "A" : xArea(i, 2) = "蘋果" : xArea(i, 3) = 20 : xArea(i, 4) = 200 : Variant/Object/Range
If T = "" Or InStr(TT & "/", "/" & T & "/") Then GoTo 101
' ----------------------------------------------------------------------------------------------
' 2(i) : TT & "/" = "/" : "/" & T & "/" = "/A/" : InStr(TT & "/", "/" & T & "/") = 0 : Long
' 3(i) : TT & "/" = "/A" : "/" & T & "/" = "/B/" : InStr(TT & "/", "/" & T & "/") = 0 : Long
' 4(i) : TT & "/" = "/A/B" : "/" & T & "/" = "/A/" : InStr(TT & "/", "/" & T & "/") = 1 : Long
' 5(i) : TT & "/" = "/A/B" : "/" & T & "/" = "/B/" : InStr(TT & "/", "/" & T & "/") = 1 : Long
' 6(i) : TT & "/" = "/A/B" : "/" & T & "/" = "/C/" : InStr(TT & "/", "/" & T & "/") = 0 : Long
' 7(i) : TT & "/" = "/A/B/C" : "/" & T & "/" = "/A/" : InStr(TT & "/", "/" & T & "/") = 1 : Long
' ----------------------------------------------------------------------------------------------
' InStr(TT & "/", "/" & T & "/") 的意思為當第一次讀取過的工作表名稱會寫入到變數 TT 的字串中,
' 因為已經做過篩選了, 所以當再次讀取到曾記錄過的名稱時跳過, 而 "/" 則是要區分各工作表名的區隔，
' 不會重覆，讓 InStr 容易判斷，而不會產生錯誤的判斷；
' InStr(TT & "/", "/" & T & "/")　用 "/' 分隔可以清楚分別 A, AA, AAA 或 A1, A11, A111，而不會誤判！
' 而且理論上, 工作表名稱不會有 "/" 字元，若用其它符號，就要考慮工作表表名稱是否含有這個符號，
' 例如：用 "-" 分隔，就可能對 1-1, 1-11, 1-111 造成相似工作表名稱之誤判！！
' ----------------------------------------------------------------------------------------------
On Error Resume Next
Set Sht = Sheets(T)
On Error GoTo 0
If Sht Is Nothing Then Set Sht = Sheets.Add(after:=Sheets(Sheets.Count)): Sht.Name = T ' Sht 不存在
Sht.UsedRange.Clear
With xArea
.Parent.Select ' xArea.Parent.Name = "彙總表" : Variant/String
.AutoFilter Field:=1, Criteria1:=T ' T = "A" : T = "B" : T = "C" : String
' AutoFilter 會依據 Criteria1 的條件匯集，標題位置並不會異動
.Copy Sht.[B1] ' 包含標題與內容一一複製到 "A"、"B"、"C" 各別的工作表單內
End With
TT = TT & "/" & T ' TT = "/A" : TT = "/A/B" : TT = "/A/B/C" ： String (判斷字串 TT 逐一增加)
101:
Next i
ActiveSheet.AutoFilterMode = False ' 回復到原始最初的 "彙總表" 之排序前內容順序
End Sub

複製代碼

1 評分人數

准提部林: 精彩, 大增益之作!金錢 + 5

版主 Rank: 7 Rank: 7 Rank: 7

准提部林

帖子: 2834
主題: 10
精華: 0
積分: 2890
點名: 0
作業系統: 〔略〕
軟體版本: 〔略〕
閱讀權限: 100
性別: 男
來自: 〔略〕
註冊時間: 2013-5-13
最後登錄: 2024-11-23

25^#

發表於 2016-2-27 10:11 | 只看該作者

回復 24# 千暉尋

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

千暉尋

中學生 Rank: 2

帖子: 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這句語法就能避開重覆值的作用.

千暉尋

中學生 Rank: 2

帖子: 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次都會是相同的),不知道對不對!

帖子: 2035
主題: 24
精華: 0
積分: 2031
點名: 0
作業系統: Win7
軟體版本: Office2010
閱讀權限: 100
性別: 男
註冊時間: 2012-3-22
最後登錄: 2024-2-1

22^#

發表於 2016-2-26 13:06 | 只看該作者

回復 19# Hsieh
終於抓到問題癥結了，連夢睡中也在捺悶。

ar(0) = Array(.[B1], .[C1], .[D1], .[E1])

複製代碼

.[B1] 傳入的是 Range 物件，而非字串；故會造成『執行階段： 13 「型態不符」』，故改以下列語法處裡：

ar(0) = Array(.[B1].Value & "", .[C1].Value, .[D1].Value, .[E1].Value)

複製代碼

其它內容維持不變。

Sub ex() ' Hsieh
Dim ar(0 To 1), ay()
Set d = CreateObject("Scripting.Dictionary")
With Sheets("彙總表")
For Each a In .Range(.[B2], .[B2].End(xlDown))
If IsEmpty(d(a & "")) Then
' ar(0) = Array(.[B1], .[C1], .[D1], .[E1])
' .[B1] 傳入的是 Range 物件，而非字串；故會造成『執行階段： 13 「型態不符」』，故改以下列語法處裡：
ar(0) = Array(.[B1].Value & "", .[C1].Value, .[D1].Value, .[E1].Value)
ar(1) = Application.Transpose(Application.Transpose(a.Resize(, 4).Value))
d(a & "") = ar ' a & "" 即等於 CStr(a)。將 a : Variant 轉換為 String 型態
Else
ay = d(a & "")
s = UBound(ay)
ReDim Preserve ay(s + 1)
ay(s + 1) = Application.Transpose(Application.Transpose(a.Resize(, 4).Value))
d(a & "") = ay
Erase ay
End If
Next
For Each sh In Sheets
If d.exists(sh.Name) = True Then
ay = d(sh.Name)
sh.Cells.Clear
sh.[B1].Resize(UBound(ay) + 1, 4) = Application.Transpose(Application.Transpose(ay))
d.Remove sh.Name
End If
Next ' d.Count = 0 : Variant/Long
For Each ky In d.keys
With Sheets.Add(after:=Sheets(Sheets.Count))
.Name = ky
ay = d(ky)
.[B1].Resize(UBound(ay) + 1, 4) = Application.Transpose(Application.Transpose(ay))
End With
Next
End With
End Sub

複製代碼

帖子: 2035
主題: 24
精華: 0
積分: 2031
點名: 0
作業系統: Win7
軟體版本: Office2010
閱讀權限: 100
性別: 男
註冊時間: 2012-3-22
最後登錄: 2024-2-1

21^#

發表於 2016-2-25 09:39 | 只看該作者

回復 19# Hsieh

Sub ex() ' Hsieh
Dim ar(0 To 1), ay(), txt$, rng As Range, cts As Integer
Set d = CreateObject("Scripting.Dictionary")
With Sheets("彙總表")
For Each a In .Range(.[B2], .[B2].End(xlDown))
If IsEmpty(d(a & "")) Then
ar(0) = Array(.[B1], .[C1], .[D1], .[E1])
ar(1) = Application.Transpose(Application.Transpose(a.Resize(, 4).Value))
d(a & "") = ar ' a & "" 即等於 CStr(a)。將 a : Variant 轉換為 String 型態
Else
ay = d(a & "")
s = UBound(ay)
ReDim Preserve ay(s + 1)
ay(s + 1) = Application.Transpose(Application.Transpose(a.Resize(, 4).Value))
d(a & "") = ay
Erase ay
End If
' d(CStr(a)) = Array(d(CStr(a)), a.Resize(, 4).Value)
' a & "" 即等於 CStr(a)。將 a : Variant 轉換為 String 型態
Next ' d.Count = 3 : Variant/Long
For Each sh In Sheets ' sh : Variant/Object/工作表1/工作表8
If sh.Name <> "彙總表" And d.exists(sh.Name) = True Then
ay = d(sh.Name)
' sh.[B1].Resize(UBound(ay) + 1, 4) = Application.Transpose(Application.Transpose(ay))
' 直行至上一行則產生『執行階段： 13 「型態不符」』，故改以下列語法處裡：
Set rng = sh.[B1]
Sheets("彙總表").[B1:E1].Copy rng
For cts = 1 To UBound(ay)
rng.Offset(cts).Resize(1, 4) = Application.Transpose(Application.Transpose(ay(cts)))
Next cts
d.Remove sh.Name
End If
Next ' d.Count = 0 : Variant/Long
For Each ky In d.keys
With Sheets.Add(after:=Sheets(Sheets.Count))
.Name = ky
ay = d(ky)
' .[B1].Resize(UBound(ay) + 1, 4) = Application.Transpose(Application.Transpose(ay))
' 直行至上一行則產生『執行階段： 13 「型態不符」』，故改以下列語法處裡：
Set rng = .[B1]
Sheets("彙總表").[B1:E1].Copy rng
For cts = 1 To UBound(ay)
rng.Offset(cts).Resize(1, 4) = Application.Transpose(Application.Transpose(ay(cts)))
Next cts
End With
Next
End With
End Sub

複製代碼

帖子: 2035
主題: 24
精華: 0
積分: 2031
點名: 0
作業系統: Win7
軟體版本: Office2010
閱讀權限: 100
性別: 男
註冊時間: 2012-3-22
最後登錄: 2024-2-1

20^#

發表於 2016-2-23 09:21 | 只看該作者

本帖最後由 c_c_lai 於 2016-2-23 09:22 編輯

回復 19# Hsieh

sh.[B4].Resize(UBound(ay) + 1, 4) = Application.Transpose(Application.Transpose(ay))

複製代碼

執行到此行，即產生 "型態不符 (#13)"