Блог

Я работаю над макрокомандой, которая копирует каждый лист и сохраняет его как отдельную книгу, но в какой-то момент в макрокоманде мне нужно очистить пару ячеек в строке 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 amp; "" amp; "Department Expenses - Split"
    MkDir FolderName

    'Copy every visible sheet to a new workbook
    For Each sh In Sourcewb.Worksheets
        filterRow = sh.Range("Z" amp; 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"
 

Вы можете попробовать что-то вроде этого: сначала откройте книгу в папке, в которую вы хотите скопировать листы, а затем выполните редактирование и фильтрацию после сохранения каждого листа в той же папке, в которой вы открываете книгу. Вы получали сообщение об ошибке, потому что вы не соответствовали 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" amp; sh.Rows.Count).End(xlUp).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" amp; 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 amp; "" amp; xWs.Name amp; ".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." amp; vbNewLine amp; vbNewLine amp; vbCrLf amp; Err.Number amp; " " amp; Err.Description, vbCritical, "Error!"

    End Sub