Re: [算表] excel 篩選後另存新檔(輸出多個檔案)(VBA)
用以下程式碼改寫即可， VBA 的使用方法請看精華區或之前的文章
Option Explicit
Sub Marco1()
Dim wbAgency As Workbook
Dim wsAct As Worksheet
Dim wsCrit As Worksheet
Dim wsAgency As Worksheet
Dim rngCrit As Range
Dim LastRow As Long
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set wsAct = ActiveSheet
Set wsCrit = Worksheets.Add
LastRow = wsAct.Range("A" & Rows.Count).End(xlUp).Row
wsAct.Range("A1:L" & LastRow).AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=wsCrit.Range("A1")
Set rngCrit = wsCrit.Range("A2")
While rngCrit.Value <> ""
Set wsAgency = Worksheets.Add
wsAct.Range("A1:L" & LastRow).AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=rngCrit.Offset(-1).Resize(2), CopyToRange:=wsAgency.Range("A1")
wsAgency.Copy
Set wbAgency = ActiveWorkbook
wbAgency.ActiveSheet.Columns("A:L").AutoFit
wbAgency.SaveAs Filename:=ThisWorkbook.Path & Application.PathSeparator & _
rngCrit & ".xls"
wbAgency.Close
rngCrit.EntireRow.Delete
wsAgency.Delete
Set rngCrit = wsCrit.Range("A2")
Wend
wsCrit.Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox ("完成!")
End Sub
※ 引述《arion ()》之銘言：
: ※ 引述《arion ()》之銘言：
: : 軟體: Excel
: : 版本: 2003
: : 請問有沒有辦法用巨集寫出讓 excel 自動另存新檔呢？
: : 我目前作法是 先用自動篩選 選出每筆的資料 然後另存新檔
: : 存檔的名稱需改為那一筆資料的名稱
: : 這樣的動作要重複數十次 手指都快抽筋了
: : 不曉得有沒有好心的大大可以指點迷津啊？
: : 篩選前 篩選後
: : ________ ________
: : AAAAAAAA AAAAAAAA
: : BBBBBBBB -篩選 A--> --> 另存新檔名為 AAAAAAAA
: : CCCCCCCC
: 感謝windknife18大大！！
: 可是我用了這個巨集所產生出來另存的檔案 只有篩選到A與B欄
: 可以幫我改成篩選A到L欄 並且自動調整格式嗎？
: ps. 因為每欄的字元大概有20幾個 所以儲存格會太窄 遮到資料
: 原本我都是選取資料 再點選兩下 然後excel 會自動調整格式
: 謝謝～～
--
※ 發信站: 批踢踢實業坊(ptt.cc)
◆ From: 61.229.81.22
推
05/11 23:33, , 1F
05/11 23:33, 1F
→
05/12 08:05, , 2F
05/12 08:05, 2F