VBA to copy one worksheet to multiple other worksheets in MS Access

问题

I am looking to copy an existing (already created worksheet) into about 500 workbooks (*.xlsx) that all reside in the same folder. Another user (@tigeravatar) was able to generate the below code that could be utilized in MS Excel but they asked me to open up another question since I didnt clarify my desire to use it in MS Access.

My rudimentary knowledge of VBA tells me I need to to do something like 'Dim ObjXL As Objectand thenSet ObjXL = CreateObject("Excel.Application") but beyond that I am unsure how to proceed.

Simply need the above code converted so that it can utilized in MS Access as it works perfectly in MS Excel

Sub Command0_Click()
    Dim wbMaster As Workbook
    Set wbMaster = ThisWorkbook

    Dim wsCopy As Worksheet
    Set wsCopy = wbMaster.Worksheets("Babelfish")

    Dim sFolderPath As String
    sFolderPath = wbMaster.Path & "\PLOGs\"
    If Right(sFolderPath, 1) <> "\" Then sFolderPath = sFolderPath & "\"

    Dim sFileName As String
    sFileName = Dir(sFolderPath & "*.xlsx")

    'Disable screenupdating (to prevent "screen flickering" so macro runs smoother)
    'Disable alerts (to suppress "Are you sure?" prompts during worksheet deletion)
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
    End With

    'Begin loop through files in the folder
    Do While Len(sFileName) > 0

        Dim sWBOpenPassword As String
        Dim sWBProtectPassword As String
        Select Case sFileName
            'Specify workbook names that require passwords here
            Case "Book2.xlsx", "Another Protected File.xlsx", "Third generic password file.xlsx"
                sWBOpenPassword = "password"
                sWBProtectPassword = "secondpassword"

            'If different books require different passwords, can specify additional names with their unique passwords
            Case "Book3.xlsx"
                sWBOpenPassword = "book3openpassword"
                sWBProtectPassword = "book3protectionpassword"

            'Keep specifying excel file names and their passwords until completed
            Case "Book10.xlsx", "Book257.xlsx"
                sWBOpenPassword = "GenericOpenPW2"
                sWBProtectPassword = "GenericProtectPW2"

            'etc...


            'Case Else will handle the remaining workbooks that don't require passwords
            Case Else
                sWBOpenPassword = ""
                sWBProtectPassword = ""

        End Select

        'Open file using password (if any)
        With Workbooks.Open(sFolderPath & sFileName, , , , Password:=sWBOpenPassword)

            Dim bProtectedWB As Boolean
            bProtectedWB = False    'Reset protected wb check to false

            'Check if workbook is protected and if so unprotect it using the specified protection password
            If .ProtectStructure = True Then bProtectedWB = True
            If bProtectedWB = True Then .Unprotect sWBProtectPassword

            On Error Resume Next    'Suppress error if copied worksheet does not yet exist
            .Worksheets(wsCopy.Name).Delete 'Delete existing sheet if it exists
            On Error GoTo 0         'Remove "On Error Resume Next" condition


            wsCopy.Copy After:=.Worksheets(.Worksheets.Count)   'Copy template into the workbook
            .Worksheets(wsCopy.Name).Cells.Replace wbMaster.Name, .Name 'Change references from master workbook to current workbook

            'If workbook was protected, reprotect it with same protection password
            If bProtectedWB = True Then .Protect sWBProtectPassword

            'Close file and save the changes
            .Close True
        End With

        sFileName = Dir 'Advance to next file in the folder
    Loop

    'Re-enable screenupdating and alerts
    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
    End With
End Sub

I desire the same end result as the other thread (to copy one worksheet into multiple other worksheets) but just need it to work in MS Access.

回答1:

Start by making sure you have added the reference to the Excel Object Library (I'm on 365 so mine is currently 16.0)

then the following adjustments to your code will work... basically defining that xl is an excel application and then preceding workbook calls with xl.

Sub Command0_Click()
Dim xl As Excel.Application
Dim wbMaster As Excel.Workbook
Set xl = New Excel.Application
Set wbMaster = xl.Workbooks.Open("C:\TEMP\OrWhateverYourPathAndFileNameIs.xlsx")

Dim wsCopy As Excel.Worksheet
Set wsCopy = wbMaster.Worksheets("Babelfish")

Dim sFolderPath As String
sFolderPath = wbMaster.Path & "\PLOGs\"
If Right(sFolderPath, 1) <> "\" Then sFolderPath = sFolderPath & "\"

Dim sFileName As String
sFileName = Dir(sFolderPath & "*.xlsx")

'Disable screenupdating (to prevent "screen flickering" so macro runs smoother)
'Disable alerts (to suppress "Are you sure?" prompts during worksheet deletion)
xl.ScreenUpdating = False
xl.DisplayAlerts = False

'Begin loop through files in the folder
Do While Len(sFileName) > 0

    Dim sWBOpenPassword As String
    Dim sWBProtectPassword As String
    Select Case sFileName
        'Specify workbook names that require passwords here
        Case "Book2.xlsx", "Another Protected File.xlsx", "Third generic password file.xlsx"
            sWBOpenPassword = "password"
            sWBProtectPassword = "secondpassword"

        'If different books require different passwords, can specify additional names with their unique passwords
        Case "Book3.xlsx"
            sWBOpenPassword = "book3openpassword"
            sWBProtectPassword = "book3protectionpassword"

        'Keep specifying excel file names and their passwords until completed
        Case "Book10.xlsx", "Book257.xlsx"
            sWBOpenPassword = "GenericOpenPW2"
            sWBProtectPassword = "GenericProtectPW2"

        'etc...


        'Case Else will handle the remaining workbooks that don't require passwords
        Case Else
            sWBOpenPassword = ""
            sWBProtectPassword = ""

    End Select

    'Open file using password (if any)
    With xl.Workbooks.Open(sFolderPath & sFileName, , , , Password:=sWBOpenPassword)

        Dim bProtectedWB As Boolean
        bProtectedWB = False    'Reset protected wb check to false

        'Check if workbook is protected and if so unprotect it using the specified protection password
        If .ProtectStructure = True Then bProtectedWB = True
        If bProtectedWB = True Then .Unprotect sWBProtectPassword

        On Error Resume Next    'Suppress error if copied worksheet does not yet exist
        .Worksheets(wsCopy.Name).Delete 'Delete existing sheet if it exists
        On Error GoTo 0         'Remove "On Error Resume Next" condition


        wsCopy.Copy After:=.Worksheets(.Worksheets.Count)   'Copy template into the workbook
        .Worksheets(wsCopy.Name).Cells.Replace wbMaster.Name, .Name 'Change references from master workbook to current workbook

        'If workbook was protected, reprotect it with same protection password
        If bProtectedWB = True Then .Protect sWBProtectPassword

        'Close file and save the changes
        .Close True
    End With

    sFileName = Dir 'Advance to next file in the folder
Loop

'Re-enable screenupdating and alerts
xl.ScreenUpdating = True
xl.DisplayAlerts = True

End Sub

来源：https://stackoverflow.com/questions/57207978/vba-to-copy-one-worksheet-to-multiple-other-worksheets-in-ms-access