Excel VBA遍历过滤条件并将数据另存为新工作簿答案

【问题标题】：Excel VBA loop through filter criteria and save data as new workbokExcel VBA遍历过滤条件并将数据另存为新工作簿
【发布时间】：2019-06-01 07:53:57
【问题描述】：

我正在尝试创建一个宏： - 在数据表上放置一个自动过滤器 - 遍历第 9 列中的所有条件 - 复制数据并作为新工作簿保存到文件夹 - 使用过滤条件作为工作簿的名称

【问题讨论】：

欢迎来到 Stack Overflow。请使用tour 并阅读How to Ask。 Stack Overflow 不是免费的脚本编写服务。预计您自己的研究和代码尝试。编辑问题以将您的代码包含在 Minimal, Complete, and Verifiable 示例中。

标签： excel vba loops

【解决方案1】：

Sub SplitFile()
Application.ScreenUpdating = False
Dim x As Range
Dim rng As Range
Dim rng1 As Range
Dim last As Long
Dim sht As String
Dim newBook As Excel.Workbook
Dim Workbk As Excel.Workbook

Dim dir As String
    dir = Range("F12").Value

'Specify sheet name in which the data is stored
Sheets("Data").Select
sht = "Data"

'Workbook where VBA code resides
Set Workbk = ThisWorkbook

'filter column
last = Workbk.Sheets(sht).Cells(Rows.Count, "I").End(xlUp).Row

With Workbk.Sheets(sht)
Set rng = .Range("A1:M" & last)
End With

Workbk.Sheets(sht).Range("I1:M" & last).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("AA1"), Unique:=True
For Each x In Workbk.Sheets(sht).Range([AA2], Cells(Rows.Count, "AA").End(xlUp))

If Not GetWorksheet(x.Text) Is Nothing Then
Sheets(x.Text).Delete
End If

With rng



.AutoFilter
.AutoFilter Field:=9, Criteria1:=x.Value
.SpecialCells(xlCellTypeVisible).Copy

Workbooks.Add
ActiveSheet.Paste
    Range("A1").Select
    Columns("A:M").Select
    Columns("A:M").EntireColumn.AutoFit
    Range("A1").Select

    Dim Path1 As String

    Dim myfilename As String

    myfilename1 = Range("E2")
    myfilename = Range("I2")


    ActiveWorkbook.SaveAs Filename:=dir & "\" & myfilename1 & " - " & myfilename & ".xls", FileFormat:=xlNormal

    ActiveWorkbook.Close

End With
Next x


' Turn off filter
Workbk.Sheets(sht).AutoFilterMode = False

    Sheets("Control").Select

With Application
.CutCopyMode = False
.ScreenUpdating = True
End With

End Sub

【讨论】：

我让它工作了。可能不是最干净或最有效的，但正在做我需要的。