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

如何按一列遍历工作表和自动筛选

1 个答案: