使用VBA解析多个Excel工作簿

Question

I am not super good at VBA (my typical use cases are recording Macros, and cleaning and modifying VBA as opposed to creating anything from scratch). I'm trying to slim down ~300 excel workbooks before consolidating them all using Kutools.

I came up with a bit of vba to strip some unnecessary parts of these workbooks to enable my consolidation. This code works without issue when run on any of the workbooks individually:

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

I found an excellent bit of code on stackoverflow that runs a predetermined task across multiple workbooks that I am tried adapting for my purposes:

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

Original thread can be found here: Run same excel macro on multiple excel files

I've tried inserting my code into the the "'Do your work here" and ".Worksheets(1).Range("A1").Value = "Hello World!"" lines in the original vba, but have had no success. I've also tried similarly inserting my parsing code into a few other solutions to executing macros across multiple excel workbooks with no success.

The workbooks it calls upon are being opened and saved, but the actual work my code is trying to accomplish isn't happening (without logging an error). I suspect that a piece of the code I'm inserting is incompatible in a way that would be very obvious to someone more knowledgable than I am.

Can anyone offer some help/guidance here? I really just need code or direction on how to execute my original "PrepWorkbook" VBA on the 300 workbooks found in "C:\\Temp\\Workbooks"

Answer 1

In your first section of code, you have to align the variables and not use THISWORKBOOK, as that keeps it isolated to where it's run from. Use below the line with 'PG in comments. I also don't think you'll need the 'WITH WB code in your second macro. Your first one loops through your sheets.

Changed the name of macro for clarity

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

Answer 2

Consider this.

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

Source: https://www.rondebruin.nl/win/s3/win010.htm