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

Question

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

所有工作簿始终位于同一目录中，但它们的文件名会有所不同。 我最初尝试使用以下代码，但是即使没有更多的工作表，我也遇到了"下一张工作表"行尝试转到其复制的工作簿中的下一张工作表的问题。

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

我尝试了下面代码的变体，如果有一张或多张纸，我会计算工作表并转到单独的代码，但这也不起作用。 非常感谢任何帮助，并感谢大家的时间。

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