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

學到老死

各位大大好,  範例如附件

說明一下

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

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


謝謝各位。

yen956

試試看:

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

複製代碼

學到老死

to yen956 大大，我執行後，無反應說，我已貼到彙總表的巨集內。

yen956

回復 3# 學到老死
以下操作係以 2003為例               
你的版本請自行參考：               
1. 按 Alt+F11       
2. Double Click sheet("彙總表")       
3. 貼上 VBA Code       
4. 點巨集 Sub()…end       
5. 按 F5       

下載 (460.44 KB)

2016-2-19 17:37

學到老死

yen956大大 感謝 我成功的執行了巨集，但是寫反了@o@ 我想要的是彙總表的資料自動分類成A,B,C...... ~O~

yen956

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

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

回復 7# c_c_lai
謝謝c大的指導!!
改用c大的 UsedRange 可批次貼上, 果然簡捷多了, 謝謝指正!!

yen956

'若資料龐大, 彙出資料到分頁, 可改用本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

學到老死

~小的感謝兩位大大 指點 持續鑽研VBA的精華所在 能力上還在初學期，加倍努力中!