VBA 将一个工作表复制到 MS Access 中的多个其他工作表
VBA to copy one worksheet to multiple other worksheets in MS Access
我希望将现有（已创建的工作表）复制到大约 500 个工作簿 (*.xlsx) 中，这些工作簿都位于同一文件夹中。另一个用户 (@tigeravatar) 能够 可以在 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 中工作。
首先确保您已添加对 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
我希望将现有（已创建的工作表）复制到大约 500 个工作簿 (*.xlsx) 中，这些工作簿都位于同一文件夹中。另一个用户 (@tigeravatar) 能够
我对 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 中工作。
首先确保您已添加对 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