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