怎樣分類後貼上各自的sheet

Hero2013

請問怎樣將excel的月結單資料根據右邊的job number 用 VBA 貼在各自的sheet 上？謝 [見附件]
pls.小弟只能用錄製的功能做, 不過run VBA時經常會處理不了, 有沒有簡單的處理方法=.=

GBKEE

回復 1# Hero2013
試試看

1. Sub 分Job1()
   
2.     Dim DataBase As Range
   
3.     With Sheets("中銀支票")
   
4.         Set DataBase = .Range("a5").CurrentRegion
   
5.         'CurrentRegion 屬性  傳回 Range 物件，該物件代表目前的區域。目前區域是指以任意空白列及空白欄的組合為邊界的範圍。唯讀
   
6.         .Cells(1, .Columns.Count) = DataBase.Cells(1, DataBase.Columns.Count)  '工作表最後一欄=DataBase最後一欄的標名(job number )
   
7.         DataBase.AdvancedFilter Action:=xlFilterCopy, CopyToRange:=.Cells(1, .Columns.Count), Unique:=True
   
8.         'AdvancedFilter(進階篩選) 方法  基於準則範圍從資料清單中篩選或複製資料。如果初始選定為單個儲存格，則使用儲存格目前的區域x為Variant。
   
9.         i = 2
   
10.         .AutoFilterMode = False
    
11.         'AutoFilterMode 屬性 定如果目前在工作表上顯示有 [自動篩選] 下拉箭號，則此屬性為 True。該屬性與 FilterMode 屬性互相獨立。讀/寫 Boolean。
    
12.         '備註 如果目前顯示 [自動篩選] 下拉箭號，此屬性傳回 True。可將該屬性設定為 False，以移除該箭號，但無法將其設定為 True。可用 AutoFilter 方法對資料清單進行篩選並顯示該下拉箭號。
    
13. 
    
14.         On Error GoTo Err_Sheet
    
15.         'On Error 陳述式     啟動一個錯誤處理常式，且指定此常式在一個程序裏的位置。也可用來停止一個錯誤處理常式。
    
16. 
    
17.         Do While .Cells(i, .Columns.Count) <> ""   '執行回圈的條件:中銀支票最後一欄的i列 <>""
    
18.             DataBase.AutoFilter Field:=DataBase.Columns.Count, Criteria1:=.Cells(i, .Columns.Count)
    
19.             'AutoFilter 方法 使用 [自動篩選] 篩選出一個清單。為 Variant。
    
20.             With Sheets(.Cells(i, .Columns.Count).Value).Range("a5")
    
21.                 .CurrentRegion = ""
    
22.                 DataBase.Copy .Cells
    
23.             End With
    
24.             i = i + 1
    
25.         Loop
    
26.         .AutoFilterMode = False
    
27.         .Columns(.Columns.Count) = ""   '清除進階篩選於最後一欄的資料
    
28.     End With
    
29. Exit Sub
    
30. Err_Sheet:
    
31.     If Err = 9 Then
    
32.       With Sheets("中銀支票")
    
33.         Sheets.Add , Sheets(Sheets.Count)               '插入新的 工作表
    
34.        ' .Copy , Sheets(Sheets.Count)                   '複製 "中銀支票" 工作表(格式如 中銀支票)
    
35.         ActiveSheet.Name = .Cells(i, .Columns.Count)    '制定新工作表的名稱
    
36.         ' ActiveSheet.AutoFilterMode = False            '複製 "中銀支票" 需顯示所有資料
    
37.       End With
    
38.       Resume
    
39.       'Resume 陳述式   在錯誤處理常式結束後 , 恢復原有的執行
    
40.     Else
    
41.         MsgBox "程式錯誤 錯誤碼" & vbLf & Err
    
42.     End If
    
43. End Sub

複製代碼

Hero2013

GBKEE板主, 可以運作了, 真的謝謝你。
困擾小弟的問題, 一下子解決了^^