當某些工作簿有一張工作表，一些工作簿有很多，有些工作簿具有隱藏的工作表時，將工作表從多個工作簿復制到當前工作簿中

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