將紙張水平合並為一張

Question

我想將工作簿中的所有工作表彼此合並。

我當前的代碼如下所示：

Sub Combine()
    Dim J As Integer
    On Error Resume Next
    Sheets(1).SelectWorksheets.Add
    Sheets(1).Name = "Combined"
    Sheets(2).Activate
    Range("A1").EntireRow.Select
    Selection.Copy Destination:=Sheets(1).Range("A1")
    For J = 2 To Sheets.Count
        Sheets(J).ActivateRange("A1").Select
        Selection.CurrentRegion.Select
        Selection.Offset(1, 0).Resize(Selection.Rows.Count - 1).Select
        Selection.Copy Destination:=Sheets(1).Range("A65536").End(xlUp)(2)
    Next

End Sub

但是，我當前的輸出是：

對於此示例，我有三張紙，它們看起來如下所示：

所有這些表看起來都一樣。

我想要的輸出應如下所示：

期望的輸出

有什么建議我做錯了嗎？

感謝您的回答！

Answer 1

我寫了這篇文章，它似乎工作足夠好。 假定您將始終在每張工作表的相同范圍內進行復印（在strRange變量中設置）。 我在測試中使用的是范圍A2:A10 ，但是您可以根據數據的傳輸距離將其更改為類似於A2:T10 。 它還假定您已經有一個“組合”工作表作為Sheet1。

Sub combineSheets()

Dim rngPaste As Range 'range to paste to
Dim rngCopy As Range 'range to copy from

Dim strRange As String 'range in sheets to copy from
strRange = "A2:A10"

Set rngPaste = ActiveWorkbook.Worksheets("Combined").Range(strRange) 'initial range to paste into

Dim s As Integer
For s = 2 To Sheets.Count

    Set rngCopy = ActiveWorkbook.Worksheets(s).Range(strRange) 'copy from same range in each sheet

    rngPaste.Value = rngCopy.Value 'copy values into first sheet

    Set rngPaste = rngPaste.Offset(10, 0) 'moves paste range for next copy

Next s

End Sub

至於為什么代碼特別不起作用，它似乎只是在每次迭代時都從Sheet2復制相同的數據，因此每次移動到新表時它可能都沒有更改其選擇。 我已經有一段時間沒有使用直接選擇了，所以我不知道是哪個部分引起的，但是可以通過直接使用上面的rngPaste.Value = rngCopy.Value類的數據直接復制來避免這種rngPaste.Value = rngCopy.Value 。