篩選後另存新檔(輸出多個檔案),VBA

[JieJuen (David)]

Name    Product
大雄    A
丁丁    B
好玩    A
大雄    B
丁丁    C


Option Explicit

Sub SplitAgencies()
    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

    Set wsAct = ActiveSheet
    Set wsCrit = Worksheets.Add

    LastRow = wsAct.Range("A" & Rows.Count).End(xlUp).Row

    wsAct.Range("A1:A" & LastRow).AdvancedFilter Action:=xlFilterCopy, _
    CopyToRange:=wsCrit.Range("A1"), Unique:=True

    Set rngCrit = wsCrit.Range("A2")

    While rngCrit.Value <> ""

        Set wsAgency = Worksheets.Add
        wsAct.Range("A1:B" & LastRow).AdvancedFilter Action:=xlFilterCopy, _
        CriteriaRange:=rngCrit.Offset(-1).Resize(2), _
        CopyToRange:=wsAgency.Range("A1")
        wsAgency.Copy

        Set wbAgency = ActiveWorkbook

        Application.DisplayAlerts = False

        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



--
※ 發信站: 批踢踢實業坊(ptt.cc)
◆ From: #1A13a6VJ
         http://www.badongo.com/file/14843944