Board logo

標題: 關於寫巨集程式自動篩選判斷區的代碼複製成該代碼單獨活頁簿 [打印本頁]
作者: 學到老死    時間: 2016-2-19 12:45     標題: 關於寫巨集程式自動篩選判斷區的代碼複製成該代碼單獨活頁簿

各位大大好,  範例如附件

說明一下

有一個彙總表的活頁簿，小的想要透過巨集自動分門別類到各自的活頁簿。

PS.附件中，A,B,C的活頁簿是執行巨集後，產生出來的結果。


謝謝各位。
作者: yen956    時間: 2016-2-19 16:05

試試看:
  1. '請貼到 "彙總表"
  2. Sub 彙入總表()
  3.     Dim sh1 As Worksheet, sh2 As Worksheet
  4.     Dim Lst1 As Integer, Lst2 As Integer
  5.     Dim I As Integer, J As Integer
  6.     Set sh1 = Sheets("彙總表")
  7.     For J = 1 To Sheets.Count
  8.         If Sheets(J).Name <> "彙總表" Then
  9.             Set sh2 = Sheets(J)
  10.             Lst1 = sh1.[B65536].End(xlUp).Row
  11.             Lst2 = sh2.[B65536].End(xlUp).Row
  12.             For I = 5 To Lst2
  13.                 sh2.Cells(I, 2).Resize(1, 4).Copy sh1.Cells(Lst1 + I - 4, 2)
  14.             Next
  15.         End If
  16.     Next
  17. End Sub
複製代碼
作者: 學到老死    時間: 2016-2-19 16:46

to yen956 大大，我執行後，無反應說，我已貼到彙總表的巨集內。
作者: yen956    時間: 2016-2-19 17:37

回復 3# 學到老死
以下操作係以 2003為例               
你的版本請自行參考：               
1. 按 Alt+F11       
2. Double Click sheet("彙總表")       
3. 貼上 VBA Code       
4. 點巨集 Sub()…end       
5. 按 F5       
[attach]23287[/attach]
作者: 學到老死    時間: 2016-2-19 18:32

yen956大大 感謝 我成功的執行了巨集，但是寫反了@o@ 我想要的是彙總表的資料自動分類成A,B,C...... ~O~
作者: yen956    時間: 2016-2-19 19:39

回復 5# 學到老死
'彙出到分頁
'先決條件:"彙總表"欄B中的sheets必須存在
Sub 彙出到分頁()
    Dim sh1 As Worksheet, sh2 As Worksheet
    Dim Lst1 As Integer, Lst2 As Integer
    Dim I As Integer, J As Integer, shName As String
    Set sh1 = Sheets("彙總表")
    Lst1 = sh1.[B65536].End(xlUp).Row
    For I = 5 To Lst1
        shName = sh1.Cells(I, 2)
        For J = 1 To Sheets.Count
            If Sheets(J).Name = shName Then
                Lst2 = Sheets(J).[B65536].End(xlUp).Row + 1
                If Lst2 < 5 Then Lst2 = 5
                sh1.Cells(I, 2).Resize(1, 4).Copy Sheets(J).Cells(Lst2, 2)
                Exit For
            End If
        Next
    Next
End Sub
作者: c_c_lai    時間: 2016-2-20 08:56

回復 5# 學到老死
套用 yen956 大大的現成程式：
  1. '  請貼到 "彙總表"
  2. Sub 彙入總表()
  3.     Dim sh1 As Worksheet, sh2 As Worksheet
  4.     Dim Lst1 As Integer
  5.     Dim J As Integer
  6.    
  7.     Set sh1 = Sheets("彙總表")
  8.     sh1.Cells.Clear
  9.    
  10.     For J = 1 To Sheets.Count
  11.         If Sheets(J).Name <> "彙總表" Then
  12.             Set sh2 = Sheets(J)
  13.             Lst1 = sh1.[B65536].End(xlUp).Row + 1
  14.            '  sh2.UsedRange.Address = "$B$4:$E$7" : String
  15.            '  sh2.UsedRange.Offset(1, 0).Address = "$B$5:$E$8" : String
  16.            sh2.UsedRange.Offset(1, 0).Copy sh1.Cells(Lst1, 2)
  17.         End If
  18.     Next
  19. End Sub
複製代碼
作者: yen956    時間: 2016-2-20 09:25

本帖最後由 yen956 於 2016-2-20 09:26 編輯

回復 7# c_c_lai
謝謝c大的指導!!
改用c大的 UsedRange 可批次貼上, 果然簡捷多了, 謝謝指正!!
作者: yen956    時間: 2016-2-20 11:10

'若資料龐大, 彙出資料到分頁, 可改用本VBA, 會快很多
'先決條件:"彙總表"欄B中的工作表名稱的sheets必須存在
'且已按工作表名稱排序
Sub 彙出到分頁2()
    Dim sh1 As Worksheet
    Dim Lst1 As Integer, shNameCnt As Integer
    Dim I As Integer
    Set sh1 = Sheets("彙總表")
    Lst1 = sh1.[B65536].End(xlUp).Row
    I = 5
    Do
        shName = sh1.Cells(I, 2)
        sh1.[C3].FormulaR1C1 = "=COUNTIF(C[-1],""=""&R" & I & "C[-1])"   '計算同名的工作表有幾個
        sh1.Cells(I, 2).Resize(sh1.[C3], 4).Copy Sheets(shName).[B5]     '批次複製
        I = I + sh1.[C3]
    Loop Until I > Lst1
End Sub
作者: 學到老死    時間: 2016-2-20 17:09

~小的感謝兩位大大 指點 持續鑽研VBA的精華所在 能力上還在初學期，加倍努力中!
作者: c_c_lai    時間: 2016-2-21 07:37

回復 10# 學到老死
回復 9# yen956
為配合實務上的實際應用，將它整理了一下，
並引用一些可能因素，以及步局考量、而做
出的範例，提供參考看看！
  1. '  請貼到 "彙總表"
  2. Sub 彙入總表()
  3.     Dim sh1 As Worksheet, sh2 As Worksheet
  4.     Dim Lst1 As Integer
  5.     Dim J As Integer
  6.     Dim msg As Boolean
  7.    
  8.     Set sh1 = Sheets("彙總表")
  9.     sh1.Cells.Clear
  10.     msg = False
  11.    
  12.     For J = 1 To Sheets.Count
  13.         If Sheets(J).Name <> "彙總表" Then
  14.             Set sh2 = Sheets(J)
  15.             Lst1 = IIf(sh1.[B65536].End(xlUp).Row = 1, 1, sh1.[B65536].End(xlUp).Row + 1)
  16.            '  sh2.UsedRange.Address = "$B$4:$E$7" : String
  17.            '  sh2.UsedRange.Offset(1, 0).Address = "$B$5:$E$8" : String
  18.            '  第一次需先連同標題及其內容一併彙入到總表內，之後僅複製每一工作表單之內容 (不含標題在內)。
  19.            sh2.UsedRange.Offset(IIf(msg, 1, 0), 0).Copy sh1.Cells(Lst1, 2)
  20.            msg = True
  21.         End If
  22.     Next
  23. End Sub

  25. '  彙出到分頁
  26. '  應用範圍： 建立字典、大小排序、貼製複製內容、如何檢查工作表單已否存在、動態產生工作表單、
  27. '             清除暫存工作區塊、以及字典的實務應用與技巧。
  28. Sub 彙出到分頁()
  29.     Dim sh1 As Worksheet, sh2 As Worksheet, rng As Range, dic As Object
  30.     Dim Lst1 As Integer, v As Variant
  31.     Dim J As Integer, I As Integer
  32.    
  33.     Set dic = CreateObject("scripting.dictionary")
  34.     Set sh1 = Sheets("彙總表")
  35.     Lst1 = sh1.[B65536].End(xlUp).Row
  36.    
  37.     sh1.Range("B1:E" & Lst1).Copy sh1.[W1]     '  另闢戰場 (B 欄先按照字母大小排序後再行彙出到各相關工作表單)
  38.     With [W2].Resize(Lst1 - 1, 4)
  39.         .Cells.Sort Key1:=.Cells(1), Key2:=.Cells(3), Order1:=xlAscending, Header:=xlNo    '  xlDescending
  40.     End With
  41.    
  42.     For J = 2 To Lst1
  43.         dic(sh1.Range("W" & J).Text) = dic(sh1.Range("W" & J).Text) + 1
  44.     Next J
  45.    
  46.     Set rng = Sheets("彙總表").[W2]
  47.     For Each v In dic.KEYS            '   v = "A" : Variant/String
  48.         I = dic.Item(v)               '   I = 3 : Integer
  49.         J = checkShts(CStr(v))
  50.         
  51.         If J > 0 Then
  52.             Set sh2 = Sheets(J)
  53.         Else
  54.             Set sh2 = Sheets.Add(After:=Sheets(Sheets.Count))
  55.             sh2.Name = v
  56.         End If
  57.         
  58.         With sh2
  59.             .Cells.Clear
  60.             sh1.[W1:Z1].Copy .[B1]
  61.             rng.Resize(I, 4).Copy .[B2]
  62.             Set rng = rng.Offset(I)       '  Rng.Address = "$B$5" : Rng.Address = "$B$7" : String
  63.         End With                          '  Rng.Address = "$B$8" : String
  64.     Next
  65.     sh1.[W:Z].Clear                       '  清除另闢之戰場 (W 至 Z 欄間內容)
  66. End Sub

  68. Function checkShts(vSht As String) As Integer
  69.     Dim flg As Integer
  70.    
  71.     For flg = 1 To Sheets.Count
  72.         If Sheets(flg).Name = vSht Then checkShts = flg: Exit Function
  73.     Next flg
  74.     checkShts = 0
  75. End Function
複製代碼
作者: yen956    時間: 2016-2-21 13:40

'借用 c大 的概念, 新增分頁, 這樣較有彈性
'請貼到 "彙總表"
'彙出到分頁3
'判判分頁是否存在
Function shExist(ByVal shName As String) As Boolean
    Dim I As Integer
    shExist = False
    For I = 1 To Sheets.Count
        If Sheets(I).Name = shName Then
            shExist = True
            Exit Function
        End If
    Next
End Function

Sub 彙出到分頁3()
    Dim sh1 As Worksheet
    Dim Lst1 As Integer, shNameCnt As Integer
    Dim I As Integer, J As Integer
   
    '********************
    '清除分頁內容, 如有其他重要分頁, 如"統計"等, 兩列*****間, 請註解掉或刪掉
    For J = 1 To Sheets.Count
        If Sheets(J).Name <> "彙總表" Then Sheets(J).Cells.Clear
    Next
    '**************
   
    '加入原序號, 方便恢復原狀(暫放欄A,可改放別欄)
    Lst1 = [B65536].End(xlUp).Row
    [A5] = 1: Range("A5:A" & Lst1).DataSeries
   
    '按工作表名稱排序
    [A5].Resize(Lst1 - 5, 5).Sort Key1:=[B5], Order1:=xlAscending, Header:=xlNo
   
    For I = 5 To Lst1
        shName = Cells(I, 2)
        
        '判判分頁是否存在, 如不存在則新增一頁
        If Not shExist(shName) Then
            Set sh1 = Sheets.Add(After:=Sheets(Sheets.Count))
            sh1.Name = shName
        End If
        
        [C4:E4].Copy Sheets(shName).[C4]     '複製標題
        [C3].FormulaR1C1 = "=COUNTIF(C[-1],""=""&R" & I & "C[-1])"   '計算同名的工作表有幾個
        Cells(I, 2).Resize([C3], 4).Copy Sheets(shName).[B5]         '批次複製
        I = I + [C3] - 1
    Next
   
    '恢復原狀, 按原序號排序, 並清除暫存區
    [A5].Resize(Lst1 - 5, 5).Sort Key1:=[A5], Order1:=xlAscending, Header:=xlNo
    [A:A].Clear: [C3].Clear    '欄A 及 [C3] 均為暫存區
End Sub
作者: 准提部林    時間: 2016-2-21 20:11

篩選法！！！

Sub Macro1()
Dim xArea As Range, i&, T$, TT$, Sht As Worksheet
Set xArea = Range([B4], Cells(Rows.Count, "B").End(xlUp)(1, 4))
For i = 2 To xArea.Rows.Count
　　T = xArea(i, 1): Set Sht = Nothing
　　If T = "" Or InStr(TT & "/", "/" & T & "/") Then GoTo 101
　　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.UsedRange.Clear
　　With xArea
　　　　.Parent.Select
　　　　.AutoFilter Field:=1, Criteria1:=T
　　　　.Copy Sht.[B4]
　　End With
　　TT = TT & "/" & T
101: Next i
ActiveSheet.AutoFilterMode = False
End Sub
作者: yen956    時間: 2016-2-22 10:22

回復 13# 准提部林
准大你好!!
又學到一招, 直接
    Set Sht = Nothing
    If T = "" Or InStr(TT & "/", "/" & T & "/") Then GoTo 101
    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))
    End If
就可以不必先判斷sht是否存在,真高, 收下, 謝謝!!
但請問 InStr(TT & "/", "/" & T & "/")  的作用是什麼?謝謝!!
作者: lpk187    時間: 2016-2-22 11:40

回復 14# yen956


    我想InStr(TT & "/", "/" & T & "/")的意思為
當第一次讀取過的工作表名稱會寫入到變數TT的字串中，因為已經做過篩選了，所以當再次讀取到曾記錄過的名稱時跳過
而"/"則是要區分各工作表名的區隔，不會重覆，讓InStr容易判斷，而不會產生錯誤的判斷
作者: 准提部林    時間: 2016-2-22 12:00

本帖最後由 准提部林 於 2016-2-22 12:06 編輯

回復 15# lpk187


完全正確, 謝謝大出力解釋!

InStr(TT & "/", "/" & T & "/")　用"/'分隔，可以清楚分別 A AA AAA 或　A1 A11 A111，而不會誤判！！
而且理論上，工作表名稱不會有"/"字元，若用其它符號，就要考慮工作表表名稱是否含有這個符號，
例如：用"-"分隔，就可能對 1-1   1-11   1-111  相似工作表誤判！！
作者: yen956    時間: 2016-2-22 12:30

回復 16# 准提部林
回復 lpk187:
回復 准大:
謝謝兩位詳細的說明, 謝謝!!
作者: yen956    時間: 2016-2-22 15:48

'彙出到分頁4(純自我學習 VBA 用, 別無它意):
'更新版, 更新重點如下:
'1. 既然 欄A及[C3] 均為暫存區, 則應整合到同一欄中, 故[C3]應改到[A3]
'2. 兩列*****間的 清除分頁 應移 "主程式" 式內, 可避免誤刪重要資料
'3. 改用准大的概念, 不另判別分頁是否存在, 即刪除 Function shExist, 可省掉不少迴圈
'
'更正結果如下:
'請貼到 "彙總表"

Sub 彙出到分頁4()
    Dim sh1 As Worksheet
    Dim Lst1 As Integer, shName As String
    Dim i As Integer, J As Integer
    Lst1 = [B65536].End(xlUp).Row
   
    '加入原序號, 方便恢復原狀(暫放欄A,可改放別欄)
    [A5] = 1: Range("A5:A" & Lst1).DataSeries
   
    '按工作表名稱排序
    [A5].Resize(Lst1 - 5, 5).Sort Key1:=[B5], Order1:=xlAscending, Header:=xlNo
   
    '主程式
    For i = 5 To Lst1
        shName = Cells(i, 2)
        
        Set sh1 = Nothing
        On Error Resume Next
        Set sh1 = Sheets(shName)
        On Error GoTo 0
        
        '若 sh1 仍為 Nothing → 名為 shName 的工作表並不存在 → 增加新工作表
        If sh1 Is Nothing Then
            Set sh1 = Sheets.Add(After:=Sheets(Sheets.Count))
            sh1.Name = shName
        End If
        
        sh1.Cells.Clear           '清除分頁
        [B4:E4].Copy sh1.[B4]     '複製標題
        [A3].FormulaR1C1 = "=COUNTIF(C[1],""=""&R" & i & "C[1])"   '計算同名的工作表有幾個
        Cells(i, 2).Resize([A3], 4).Copy sh1.[B5]                  '批次複製同名的工作表
        i = i + [A3] - 1                '跳到下個不同名工作表, 故不用篩選
    Next
   
    '恢復原狀 → 按原序號排, 並清除暫存區
    [A5].Resize(Lst1 - 5, 5).Sort Key1:=[A5], Order1:=xlAscending, Header:=xlNo
    [A:A].Clear     '清除暫存區 欄A
End Sub
作者: Hsieh    時間: 2016-2-22 16:21

  1. Sub ex()
  2. Dim ar(0 To 1), ay()
  3. Set d = CreateObject("Scripting.Dictionary")
  4. With Sheets("彙總表")
  5. For Each a In .Range(.[B5], .[B5].End(xlDown))
  6.    If IsEmpty(d(a & "")) Then
  7.       ar(0) = Array(.[B4], .[C4], .[D4], .[E4])
  8.       ar(1) = Application.Transpose(Application.Transpose(a.Resize(, 4).Value))
  9.       d(a & "") = ar
  10.       Else
  11.       ay = d(a & "")
  12.       s = UBound(ay)
  13.       ReDim Preserve ay(s + 1)
  14.       ay(s + 1) = Application.Transpose(Application.Transpose(a.Resize(, 4).Value))
  15.       d(a & "") = ay
  16.       Erase ay
  17.     End If
  18. Next
  19. For Each sh In Sheets
  20.    If d.exists(sh.Name) = True Then
  21.       ay = d(sh.Name)
  22.       sh.[B4].Resize(UBound(ay) + 1, 4) = Application.Transpose(Application.Transpose(ay))
  23.       d.Remove sh.Name
  24.     End If
  25. Next
  26. For Each ky In d.keys
  27.    With Sheets.Add(after:=Sheets(Sheets.Count))
  28.       .Name = ky
  29.        ay = d(ky)
  30.       .[B4].Resize(UBound(ay) + 1, 4) = Application.Transpose(Application.Transpose(ay))
  31.     End With
  32. Next
  33. End With
  34. End Sub
複製代碼
回復 1# 學到老死
作者: c_c_lai    時間: 2016-2-23 09:21

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

回復 19# Hsieh
  1. sh.[B4].Resize(UBound(ay) + 1, 4) = Application.Transpose(Application.Transpose(ay))
複製代碼
執行到此行，即產生 "型態不符 (#13)"
作者: c_c_lai    時間: 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
複製代碼
作者: c_c_lai    時間: 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
複製代碼
作者: 千暉尋    時間: 2016-2-26 22:34

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

拍謝!因為不小心鑽進死巷,沒有宏觀全部語句,問了一個笨問題,原來InStr(TT & "/", "/" & T & "/") Then GoTo 101這句語法就能避開重覆值的作用.
作者: 准提部林    時間: 2016-2-27 10:11

回復 24# 千暉尋


哈！這是加深記憶的方法，
學vba，從錯誤中去修正，是好方法的！！！
作者: c_c_lai    時間: 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
複製代碼
作者: 千暉尋    時間: 2016-2-27 11:13

回復 26# c_c_lai
感謝C_C_LAI大大提供詳盡的筆記,這樣更能清楚准大的語法精妙所在!
作者: c_c_lai    時間: 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
複製代碼




歡迎光臨 麻辣家族討論版版 (http://forum.twbts.com/)