使用 VBA 解析多个 Excel 工作簿

Question

我不太擅长 VBA（我的典型用例是录制宏，清理和修改 VBA，而不是从头开始创建任何东西）。在使用 Kutools 整合它们之前，我正在尝试精简约 300 个 excel 工作簿。

我想出了一些 vba 来去除这些工作簿中一些不必要的部分，以实现我的整合。此代码在任何工作簿上单独运行时都可以正常工作：

Sub PrepWorkbook()
    Dim Sh As Worksheet
    For Each Sh In ThisWorkbook.Worksheets
        If Sh.Visible = True Then
            Sh.Activate
            Sh.Cells.Copy
            Sh.Range("A1").PasteSpecial Paste:=xlValues
            Sh.Range("A1").Select
        End If
    Next Sh
    Application.CutCopyMode = False
        Dim ws As Worksheet

    For Each ws In Worksheets
        ws.Cells.Validation.Delete
    Next ws
    Application.DisplayAlerts=FALSE
    Sheets("Instructions").Delete
    Sheets("Dropdowns").Delete
    Sheets("Dropdowns2").Delete
    Sheets("Range Reference").Delete
    Sheets("All Fields").Delete
    Sheets("ExistingData").Delete
    Application.DisplayAlerts=TRUE
End Sub

我在 stackoverflow 上发现了一段出色的代码，它跨多个工作簿运行预定任务，我尝试根据我的目的进行调整：

Sub ProcessFiles()
    Dim Filename, Pathname As String
    Dim wb As Workbook

    Pathname = ActiveWorkbook.Path & "\Files\"
    Filename = Dir(Pathname & "*.xls")
    Do While Filename <> ""
       Set wb = Workbooks.Open(Pathname & Filename)
        DoWork wb
        wb.Close SaveChanges:=True
        Filename = Dir()
    Loop
End Sub


Sub DoWork(wb As Workbook)
    With wb
        'Do your work here
        .Worksheets(1).Range("A1").Value = "Hello World!"
    End With
End Sub

原帖可以在这里找到： Run same excel macro on multiple excel files

我尝试将我的代码插入到原始 vba 中的“'Do your work here”和“.Worksheets(1).Range("A1").Value = "Hello World!"" 行中，但是没有成功。我也尝试过类似地将我的解析代码插入到其他一些解决方案中，以在多个 Excel 工作簿中执行宏但没有成功。

它调用的工作簿正在打开和保存，但我的代码试图完成的实际工作没有发生（没有记录错误）。我怀疑我插入的一段代码不兼容，这对于比我知识渊博的人来说是非常明显的。

谁能在这里提供一些帮助/指导？我真的只需要关于如何在“C:\Temp\Workbooks”中找到的 300 个工作簿上执行我原来的“PrepWorkbook”VBA 的代码或指导

Answer 1

考虑一下。

Sub Example()
    Dim MyPath As String, FilesInPath As String
    Dim MyFiles() As String, Fnum As Long
    Dim mybook As Workbook
    Dim CalcMode As Long
    Dim sh As Worksheet
    Dim ErrorYes As Boolean

    'Fill in the path\folder where the files are
    MyPath = "C:\Users\Ron\test"

    'Add a slash at the end if the user forget it
    If Right(MyPath, 1) <> "\" Then
        MyPath = MyPath & "\"
    End If

    'If there are no Excel files in the folder exit the sub
    FilesInPath = Dir(MyPath & "*.xl*")
    If FilesInPath = "" Then
        MsgBox "No files found"
        Exit Sub
    End If

    'Fill the array(myFiles)with the list of Excel files in the folder
    Fnum = 0
    Do While FilesInPath <> ""
        Fnum = Fnum + 1
        ReDim Preserve MyFiles(1 To Fnum)
        MyFiles(Fnum) = FilesInPath
        FilesInPath = Dir()
    Loop

    'Change ScreenUpdating, Calculation and EnableEvents
    With Application
        CalcMode = .Calculation
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    'Loop through all files in the array(myFiles)
    If Fnum > 0 Then
        For Fnum = LBound(MyFiles) To UBound(MyFiles)
            Set mybook = Nothing
            On Error Resume Next
            Set mybook = Workbooks.Open(MyPath & MyFiles(Fnum))
            On Error GoTo 0

            If Not mybook Is Nothing Then


                'Change cell value(s) in one worksheet in mybook
                On Error Resume Next
                With mybook.Worksheets(1)
                    If .ProtectContents = False Then
                        .Range("A1").Value = "My New Header"
                    Else
                        ErrorYes = True
                    End If
                End With


                If Err.Number > 0 Then
                    ErrorYes = True
                    Err.Clear
                    'Close mybook without saving
                    mybook.Close savechanges:=False
                Else
                    'Save and close mybook
                    mybook.Close savechanges:=True
                End If
                On Error GoTo 0
            Else
                'Not possible to open the workbook
                ErrorYes = True
            End If

        Next Fnum
    End If

    If ErrorYes = True Then
        MsgBox "There are problems in one or more files, possible problem:" _
             & vbNewLine & "protected workbook/sheet or a sheet/range that not exist"
    End If

    'Restore ScreenUpdating, Calculation and EnableEvents
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = CalcMode
    End With
End Sub

来源：https://www.rondebruin.nl/win/s3/win010.htm

Answer 2

在您的第一段代码中，您必须对齐变量而不是使用 THISWORKBOOK，因为这会使其与运行位置保持隔离。在 cmets 中使用带有 'PG 的行下方。我也不认为您在第二个宏中需要'WITH WB 代码。您的第一个循环遍历您的工作表。

为清晰起见更改了宏的名称

Sub DoWork(wb As Workbook)
Dim Sh As Worksheet
For Each Sh In wb.Sheets'PG adjustments
    If Sh.Visible = True Then
        Sh.Activate
        Sh.Cells.Copy
        Sh.Range("A1").PasteSpecial Paste:=xlValues
        Sh.Range("A1").Select
    End If
Next Sh'PG adjustments
Application.CutCopyMode = False
    Dim ws As Worksheet

For Each ws In wb.Sheets 'PG seems redundant to above, but harmless.
    ws.Cells.Validation.Delete
Next ws
Application.DisplayAlerts=FALSE
Sheets("Instructions").Delete
Sheets("Dropdowns").Delete
Sheets("Dropdowns2").Delete
Sheets("Range Reference").Delete
Sheets("All Fields").Delete
Sheets("ExistingData").Delete
Application.DisplayAlerts=TRUE
End Sub