VBA 将一个工作表复制到 MS Access 中的多个其他工作表

Question

我希望将现有的（已经创建的工作表）复制到大约 500 个工作簿 (*.xlsx) 中，这些工作簿都位于同一个文件夹中。另一个用户 (@tigeravatar) 能够generate the below code 可以在 MS Excel 中使用，但他们要求我提出另一个问题，因为我没有说明我希望在 MS Access 中使用它。

我对 VBA 的基本了解告诉我，我需要执行类似 'Dim ObjXL As Objectand thenSet ObjXL = CreateObject("Excel.Application") 之类的操作，但除此之外我不确定如何继续。

只需转换上述代码，即可在 MS Access 中使用，因为它可以在 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

我希望得到与另一个线程相同的最终结果（将一个工作表复制到多个其他工作表中），但只需要它在 MS Access 中工作。

Answer 1

首先确保您已添加对 Excel 对象库的引用（我在 365 上，所以我目前是 16.0）

然后对您的代码进行以下调整...基本上定义 xl 是一个 excel 应用程序，然后在工作簿调用之前使用 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