如何將一個excel 拆成數個execl

user999

請教各位先進  
1.如何將一個excel 拆成數個execl,如總表excel內容有好幾個班，如何拆成每班一個excel檔
2.如果可以, 又將事後 各班execl檔(加入成績),又匯成一個檔如總表中的結果
請求協助 謝謝!

GBKEE

回復 1# user999

1. Option Explicit
   
2. Sub Ex() '總表拆成數個execl : 總表與各年級活頁簿 存在同一個資料夾
   
3.     Dim wSh As Worksheet, i As Integer, wB As Workbook
   
4.     Application.DisplayAlerts = False
   
5.     Application.ScreenUpdating = False
   
6.     Set wSh = Workbooks("總表.xlsm").Sheets(1)                             '*** 總表已是開啟的 ****
   
7.     With wSh
   
8.         .Columns("A:A").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=.Cells(1, .Columns.Count), Unique:=True
   
9.         'A欄進階篩選  :->  沒有篩選準則(CriteriaRange),可篩選出不重覆的資料
   
10.         i = 2
    
11.         .AutoFilterMode = False                                             '取消 [自動篩選]
    
12.         Do While .Cells(i, .Columns.Count) <> ""                            '直到沒資料
    
13.             Set wB = Workbooks.Add(1)   '=參數:xlWBATWorksheet              '新增活頁簿(一張工作表)
    
14.             .Cells(1).AutoFilter 1, .Cells(i, .Columns.Count)               '[自動篩選] 第1欄 準則=.Cells(i, .Columns.Count)
    
15.             .Range("A1").CurrentRegion.Copy wB.Sheets(1).[a1]               '[自動篩選]依準則篩選的資料 複製到 總表
    
16.             wB.SaveAs wSh.Parent.Path & "\" & .Cells(i, .Columns.Count) & ".xlsx", FileFormat:=51   '51: 存檔為 2007 無巨集活頁簿
    
17.             wB.Close                                                        '關閉檔案
    
18.             i = i + 1                                                       '下一列資料
    
19.         Loop
    
20.         .AutoFilterMode = False
    
21.         .Cells(1, .Columns.Count).EntireColumn = ""                         '工作表最後一欄:清除篩選出不重覆的資料
    
22.      End With
    
23.     Application.DisplayAlerts = True
    
24.     Application.ScreenUpdating = True
    
25. End Sub
    
26. Sub Ex1() '數個execl 結合為總表:   總表與各年級活頁簿 存在同一個資料夾
    
27.     Dim wB As Workbook, wSh As Worksheet, xF As String
    
28.     Application.ScreenUpdating = False
    
29.     Set wSh = Workbooks("總表.xlsm").Sheets(1)
    
30.     With wSh
    
31.         .Range("a1").CurrentRegion.Offset(1).Clear
    
32.         xF = Dir(wSh.Parent.Path & "\*.xlsx")               '尋找 wSh.Parent.Path 這資料夾 副檔名為xlsx 的檔案
    
33.         Do While xF <> ""
    
34.             With Workbooks.Open(wSh.Parent.Path & "\" & xF).Sheets(1)
    
35.                 .Range("a1").CurrentRegion.Offset(1).Copy wSh.Cells(wSh.Rows.Count, 1).End(xlUp).Offset(1)
    
36.                 .Parent.Close False
    
37.             End With
    
38.             xF = Dir
    
39.         Loop
    
40.         .Range("A1").CurrentRegion.Sort Key1:=.Range("A2"), Order1:=xlAscending, Key2:=.Range( _
    
41.         "B2"), Order2:=xlAscending, Key3:=.Range("C2"), Order3:=xlAscending, _
    
42.         Header:=xlYes, OrderCustom:=1
    
43.         .Parent.Save
    
44.     End With
    
45.     Application.ScreenUpdating = True
    
46. End Sub

複製代碼

user999

回復 2# GBKEE


    謝謝您這麼詳盡快速的回覆,有您們幫助真好,謝謝!

threelin

真的是高手
vba，我還是需要好好學習