Excel VBA просматривает критерии фильтра и сохраняет данные как новый рабочий блок

Question

Я пытаюсь создать макрос, который: - помещает автофильтр в таблицу данных - Перебирает все критерии в колонке 9 - скопировать данные и сохранить как новую книгу в папку - используя критерии фильтра в качестве имени для рабочей книги

Answer 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