如何將一個excel 拆成數個execl

本帖最後由 GBKEE 於 2012-7-23 15:04 編輯

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

1toall.rar (32.51 KB)

樓主熱帖

max

GBKEE

超級版主 Rank: 8 Rank: 8

帖子: 5923
主題: 13
精華: 1
積分: 5986
點名: 0
作業系統: win10
軟體版本: Office 2010
閱讀權限: 150
性別: 男
來自: 台灣基隆
註冊時間: 2010-5-1
最後登錄: 2022-1-23

2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章 2011兔年全勤獎章

2^#

發表於 2012-7-23 17:03 | 只看該作者

回復 1# user999

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