Как перебирать таблицы и автофильтр по одному столбцу

Question

Я работаю над макросом, который копирует каждый лист и сохраняет его как отдельную книгу, но в какой-то момент в макросе мне нужно очистить пару ячеек в строке Z, а затем отфильтровать столбец Z, чтобы удалить нули. Я очень новичок в VBA, поэтому, пожалуйста, извините за уродливый код.

Макрос, который у меня есть, будет работать для разделения и сохранения файлов, но я получаю сообщение об ошибке 1004. Ошибка приложения или объекта.

Я искал другие сообщения часами и до сих пор не могу понять. Любая помощь приветствуется.

    Dim FileExtStr As String
    Dim FileFormatNum As Long
    Dim Sourcewb As Workbook
    Dim Destwb As Workbook
    Dim sh As Worksheet
    Set sh = Sheets("Table of Contents")
    Dim DateString As String
    Dim FolderName As String
    Dim filterRow As Integer




    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
    End With


    Set Sourcewb = ActiveWorkbook
    Set sh = ActiveSheet

    'Create new folder to save the new files in
    DateString = Format(Now, "yyyy-mm-dd hh-mm-ss")
    FolderName = Sourcewb.Path & "\" & "Department Expenses - Split"
    MkDir FolderName

    'Copy every visible sheet to a new workbook
    For Each sh In Sourcewb.Worksheets
        filterRow = sh.Range("Z" & Rows.Count).End(x1Up).Row 'This is the line giving me problems
        ActiveSheet.Next.Select
        Range("Z9").Select
        Selection.ClearContents
        Range("Z12").Select
        Selection.ClearContents
        Range("Z14").Select
        Selection.ClearContents
        Range("Z77").Select
        Selection.ClearContents
        Range("Z100").Select
        Selection.ClearContents
        sh.Range(filterRow).AutoFilter Field:=26, Criteria1:="<>0"

Answer 1

Вы можете попробовать что-то вроде этого: сначала откройте рабочую книгу в папке, в которую вы хотите скопировать листы, а затем выполните редактирование и фильтрацию после сохранения каждого рабочего листа в той же папке, где вы открываете рабочую книгу.Вы получили ошибку, потому что вы не отвечали требованиям Rows.Count, должно быть sh.Rows.Count, чтобы он знал, на каком листе он рассчитывает.

    Sub CopySheetsToNewWorkbook()

    Dim xPath As String
    Dim xWs As Worksheet
    Dim filterRow As Integer
    Dim questionBoxPopUp As VbMsgBoxResult

     questionBoxPopUp = MsgBox("Are you sure you want to copy each worksheets as a new workbook in the current folder?", vbQuestion + vbYesNo + vbDefaultButton1, "Copy Worksheets?")
        If questionBoxPopUp = vbNo Then Exit Sub

    On Error GoTo ErrorHandler
    xPath = Application.ActiveWorkbook.Path

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

   For Each sh In Sourcewb.Worksheets
        filterRow = sh.Range("Z" & sh.Rows.Count).End(x1Up).Row 'not too sure why you need this
        ActiveSheet.Next.Select
        Range("Z9").Select
        Selection.ClearContents
        Range("Z12").Select
        Selection.ClearContents
        Range("Z14").Select
        Selection.ClearContents
        Range("Z77").Select
        Selection.ClearContents
        Range("Z100").Select
        Selection.ClearContents
        sh.Range("Z" & filterRow).AutoFilter Field:=26, Criteria1:="<>0" 'Change column "Z" to suit your needs. I think you need jut the header range to filter it.

    For Each xWs In ActiveWorkbook.Sheets
        xWs.Copy
        Application.ActiveWorkbook.SaveAs filename:=xPath & "\" & xWs.Name & ".xlsx"
        Application.ActiveWorkbook.Close False
    Next xWs

    Application.DisplayAlerts = True
    Application.ScreenUpdating = True

    MsgBox "Process completed!", vbInformation

     Exit Sub '<--- exit here if no error occured
    ErrorHandler:
    Application.DisplayAlerts = True
        Application.ScreenUpdating = True
        Debug.Print Err.Number; Err.Description
            MsgBox "Sorry, an error occured." & vbNewLine & vbNewLine & vbCrLf & Err.Number & " " & Err.Description, vbCritical, "Error!"

    End Sub