☰

从所有打开的工作簿复制工作表并粘贴到新的主工作簿中 - 修订版

tag-icon • tag-icon microsoft-excel vba macros
从所有打开的工作簿复制工作表并粘贴到新的主工作簿中 - 修订版

我有以下由 get.digital.help.com 提供的代码

除以下两点外，代码执行正常：

  1. personal.xlsb 文件与所有其他打开的 wrkbk 一起粘贴到新的主 wrkbk 中。

    代码如何防止personal.xlsb被复制。

  2. 错误代码 ”运行时错误 9：下标超出范围“在位于“end macro”/“end sub”之前的这一行生成：

WBN.Sheets(Array("Sheet1", "Sheet2", "Sheet3")).删除

是什么原因导致了这个错误以及如何修复它？

'Name macro
'https://www.get-digital-help.com/copy-each-sheet-in-active-workbook-to-new-workbooks/#master

Sub CopySheetsToMasterWorkbook()

'this version includes option to name copied worksheets

'Dimension variables and declare data types
Dim WBN As Workbook, WB As Workbook
Dim SHT As Worksheet
 'Create a new workbook and save an object reference to variable WBN
Set WBN = Workbooks.Add
'Iterate through all open workbooks
For Each WB In Application.Workbooks
'Check if workbook name of object variable WB is not equal to name of object variable WBN
If WB.Name <> WBN.Name Then
'Go through all worksheets in object WB
For Each SHT In WB.Worksheets
'Copy worksheet to workbook WBN and place after the last worksheet
SHT.Copy After:=WBN.Sheets(WBN.Worksheets.Count)
'Adds option to name each WrkSht added to MasterWB
WBN.Sheets(WBN.Worksheets.Count).Name = Left(WB.Name, 30 - Len(SHT.Name)) & "-" & SHT.Name
'Continue with next worksheet
Next SHT
'End of If statement
End If
'Continue with next workbook
Next WB
'Disable Alerts
Application.DisplayAlerts = False
**'Delete sheet1, sheet2 and sheet3 in the new workbook WBN
WBN.Sheets(Array("Sheet1", "Sheet2", "Sheet3")).Delete**
'Enable Alerts
WBN.Application.DisplayAlerts = True
'End macro
End Sub

答案1

我如何修改代码以激活 11 个打开的工作簿中的每一个（无需对源工作簿进行硬编码特定文件名 - 我认为这需要先重命名每个工作簿）。

图案：

Const destination_name As String = "Destination.XLSX"
Dim destination As Workbook

Sub processworkbooks()
' .....
    Set destination = Application.Workbooks(destination_name)
    For Each OneWorkbook In Application.Workbooks 
        If OneWorkbook.Name <> destination_name Then
            Call CopySheet(OneWorkbook)
        End If
    Next
' .....
End Sub

Sub CopySheet(source As WorkBook)
    For Each OneSheet In source.Sheets
        OneSheet.Copy After:=destination.Sheets(destination.Sheets.Count)
    Next    
End Sub

该代码将所有打开的工作簿（目标工作簿除外）的所有工作表复制到目标工作簿中。

相关内容