当一些工作簿有一张工作表时，将工作表从多个工作簿复制到当前工作簿中，其中一些工作表中有许多工作表，一些工作表中有隐藏工作表

正如标题所说，我试图将一组工作簿中的所有可见工作表复制到一个工作簿中。

所有的工作簿总是在同一个目录下，但是它们的文件名会有所不同。 我曾尝试使用下面的代码，但我遇到的问题，“下一页”行尝试转到工作簿中的下一张工作表复制，即使没有更多的工作表。

更具体地说，我试图结合的基础工作簿有不同数量的工作表; 有的有一些，有的有很多，有的还有很多有隐藏的工作表。 我只是试图复制可见的工作表，并且需要能够处理工作簿可能有一个或多个工作表的情况。

我已经尝试了下面代码的一个变体，在那里我会计算表单，如果有一个或多个表单，则转到一个单独的代码，但那也不起作用。 任何帮助非常感谢，并感谢你所有的时间。

Sub ConslidateWorkbooks() Dim FolderPath As String Dim Filename As String Dim Sheet As Worksheet Application.ScreenUpdating = False FolderPath = "MyPath" Filename = Dir(FolderPath & "*.xls*") Do While Filename <> "" Workbooks.Open Filename:=FolderPath & Filename For Each Sheet In ActiveWorkbook.Sheets Sheet.Copy after:=ThisWorkbook.Sheets(1) Next Sheet Workbooks(Filename).Close Filename = Dir() Loop Application.ScreenUpdating = True End Sub 

Answer 1

您应该将对象引用分配给您打开的工作簿，而不是依赖于ActiveWorkbook ：

 Dim wb As Workbook Do While Filename <> "" Set wb = Workbooks.Open(Filename:=FolderPath & Filename) For Each Sheet In wb.Sheets If Sheet.Visible = xlSheetVisible Then 'only copy visible sheets Sheet.Copy After:=ThisWorkbook.Sheets(1) End If Next Sheet wb.Close Filename = Dir() Loop 

通过避免使用ActiveWorkbook ，您将解决用户提出的问题，您的代码不期待。

Answer 2

尝试一下这些方面：

 Sub ConslidateWorkbooks() 'Code to pull sheets from multiple Excel files in one file directory 'into master "Consolidation" sheet. Dim FolderPath As String Dim Filename As String Dim Sheet As Worksheet With ActiveSheet Range("A1").Activate End With Application.ScreenUpdating = False FolderPath = ActiveWorkbook.Path & "\" Filename = Dir(FolderPath & "*.xls*") Do While Filename <> "" Workbooks.Open Filename:=FolderPath & Filename, ReadOnly:=True For Each Sheet In ActiveWorkbook.Sheets If Sheet.Visible = TRUE Then copyOrRefreshSheet ThisWorkbook, Sheet End If Next Sheet Workbooks(Filename).Close Filename = Dir() Loop Application.ScreenUpdating = True End Sub Sub copyOrRefreshSheet(destWb As Workbook, sourceWs As Worksheet) Dim ws As Worksheet On Error Resume Next Set ws = destWb.Worksheets(sourceWs.Name) On Error GoTo 0 If ws Is Nothing Then sourceWs.Copy After:=destWb.Worksheets(destWb.Worksheets.Count) Else ws.Cells.ClearContents ws.Range(sourceWs.UsedRange.Address).Value = sourceWs.UsedRange.Value2 End If End Sub