VBA将一个工作表复制到MS Access中的多个其他工作表 [英] VBA to copy one worksheet to multiple other worksheets in MS Access

问题描述

我希望将现有(已创建的工作表)复制到全部位于同一文件夹中的约500个工作簿(* .xlsx)中.另一个用户(@tigeravatar)能够

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.

我对VBA的基本了解告诉我，我需要执行类似将ObjXL作为对象设置and then Set ObjXL = CreateObject("Excel.Application"))的操作，但除此之外，我不确定如何进行操作.

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.

只需将上面的代码转换为可以在MS Access中使用，因为它可以在MS Excel中完美运行

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

我希望与另一个线程具有相同的最终结果(将一个工作表复制到多个其他工作表中)，但只需要它在MS Access中工作即可.

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.

推荐答案

首先请确保已将引用添加到Excel对象库(我在365上，所以我的当前是16.0)

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

然后对您的代码进行以下调整即可...基本上定义xl是excel应用程序，然后在工作簿调用之前加上xl.

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

这篇关于VBA将一个工作表复制到MS Access中的多个其他工作表的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！