麻辣家族討論版版 - Powered by Discuz! Board

Option Explicit
Sub Ex() '總表拆成數個execl : 總表與各年級活頁簿存在同一個資料夾
Dim wSh As Worksheet, i As Integer, wB As Workbook
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Set wSh = Workbooks("總表.xlsm").Sheets(1) '*** 總表已是開啟的 ****
With wSh
.Columns("A:A").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=.Cells(1, .Columns.Count), Unique:=True
'A欄進階篩選 :-> 沒有篩選準則(CriteriaRange),可篩選出不重覆的資料
i = 2
.AutoFilterMode = False '取消 [自動篩選]
Do While .Cells(i, .Columns.Count) <> "" '直到沒資料
Set wB = Workbooks.Add(1) '=參數:xlWBATWorksheet '新增活頁簿(一張工作表)
.Cells(1).AutoFilter 1, .Cells(i, .Columns.Count) '[自動篩選] 第1欄準則=.Cells(i, .Columns.Count)
.Range("A1").CurrentRegion.Copy wB.Sheets(1).[a1] '[自動篩選]依準則篩選的資料複製到總表
wB.SaveAs wSh.Parent.Path & "\" & .Cells(i, .Columns.Count) & ".xlsx", FileFormat:=51 '51: 存檔為 2007 無巨集活頁簿
wB.Close '關閉檔案
i = i + 1 '下一列資料
Loop
.AutoFilterMode = False
.Cells(1, .Columns.Count).EntireColumn = "" '工作表最後一欄:清除篩選出不重覆的資料
End With
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Sub Ex1() '數個execl 結合為總表: 總表與各年級活頁簿存在同一個資料夾
Dim wB As Workbook, wSh As Worksheet, xF As String
Application.ScreenUpdating = False
Set wSh = Workbooks("總表.xlsm").Sheets(1)
With wSh
.Range("a1").CurrentRegion.Offset(1).Clear
xF = Dir(wSh.Parent.Path & "\*.xlsx") '尋找 wSh.Parent.Path 這資料夾副檔名為xlsx 的檔案
Do While xF <> ""
With Workbooks.Open(wSh.Parent.Path & "\" & xF).Sheets(1)
.Range("a1").CurrentRegion.Offset(1).Copy wSh.Cells(wSh.Rows.Count, 1).End(xlUp).Offset(1)
.Parent.Close False
End With
xF = Dir
Loop
.Range("A1").CurrentRegion.Sort Key1:=.Range("A2"), Order1:=xlAscending, Key2:=.Range( _
"B2"), Order2:=xlAscending, Key3:=.Range("C2"), Order3:=xlAscending, _
Header:=xlYes, OrderCustom:=1
.Parent.Save
End With
Application.ScreenUpdating = True
End Sub

複製代碼