Скопировать отфильтрованный лист Excel

[PavelAA]

Есть книга Excel, с помощью фильтров я выделил необходимые данные, теперь хочу, чтобы скопировались в новую книгу только отфильтрованные данные.
Данный код копирует полностью... без фильтров.

Код: Выделить всё

Sub Макрос1()
'
' Макрос1 Макрос
'
' Сочетание клавиш: Ctrl+q
    On Error Resume Next
    ' название подпапки, в которую по-умолчанию будет предложено сохранить файл
   Const REPORTS_FOLDER = "Акты\"
    ' создаём папку для файла, если её ещё нет
   MkDir ThisWorkbook.Path & "\" & REPORTS_FOLDER
    ' выбираем стартовую папку
   ChDrive Left(ThisWorkbook.Path, 1): ChDir ThisWorkbook.Path & "\" & REPORTS_FOLDER

    Filename = Application.GetSaveAsFilename("отчёт.xlsx", "Отчёты Excel (*.xlsx*),", , _
                                             "Введите имя файла для сохраняемого отчёта", "Сохранить")
    ' если пользователь отказался от выбора имени файла - отменяем сохранение листа в файл
   If VarType(Filename) = vbBoolean Then Exit Sub

    ' копируем активный лист (при этом создаётся новая книга)
   Err.Clear: ActiveSheet.Copy: DoEvents
    If Err Then Exit Sub    ' произошла какая-то ошибка при попытке копирования листа

    ' убеждаемся, что активной книгой является копия листа
   If ActiveWorkbook.Worksheets.Count = 1 And ActiveWorkbook.Path = "" Then
        ' сохраняем файл под заданным именем в формате Excel 2003
       ActiveWorkbook.SaveAs Filename, xlOpenXMLWorkbook
       
        ' закрываем сохранённый файл
       ' (удалите следующую строку, если закрывать созданный файл не требуется)
       ActiveWorkbook.Close False
    End If
End Sub

[Template]

А ежели так ?

Код: Выделить всё

Sub Макрос1()

    Dim wsCopySheet As Worksheet, wbReport As Workbook
    Dim strFolder As String, varFilename As Variant

    strFolder = ThisWorkbook.Path & "\Акты\"

    If Len(Dir(strFolder, vbDirectory)) = 0 Then MkDir strFolder

    ChDrive Left(strFolder, 1): ChDir strFolder

    varFilename = Application.GetSaveAsFilename( _
    "отчёт.xlsx", "Отчёты Excel (*.xlsx*),", , _
    "Введите имя файла для сохраняемого отчёта", "Сохранить2")

    If varFilename <> False Then
       'Application.ScreenUpdating = False

       Set wsCopySheet = ThisWorkbook.ActiveSheet
       Set wbReport = Application.Workbooks.Add(xlWBATWorksheet)

       wsCopySheet.Cells.Copy
       wbReport.Worksheets(1).Paste

       wbReport.SaveAs varFilename, xlOpenXMLWorkbook
       ThisWorkbook.Close False 'wsCopySheet.Parent.Close False

       '''Application.ScreenUpdating = True
    End If

End Sub