将 sheet 水平合并为一个 sheet

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

然而，我当前的输出是：

对于这个例子，我有三张纸，它们如下所示：

所有这些表格看起来都一样。

我想要的输出应该是这样的：

Desired Output

对我做错了什么有什么建议吗？

感谢您的回答！

Answer 1

我写了这个，它似乎工作得很好。它假定您总是从每个 sheet（在 strRange 变量中设置）中的相同范围进行复制。我在测试中使用范围 A2:A10，但您可以将其更改为类似 A2:T10 的范围，具体取决于数据的范围。它还假设您已经有一个 "Combined" sheet 作为您的 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 复制相同的数据，所以它可能只是在你每次移动到一个新的时都不会改变它的选择sheet。我有一段时间没有使用直接选择，所以我不知道是哪个部分导致的，但是可以通过使用上面的 rngPaste.Value = rngCopy.Value 之类的东西更直接地复制数据来避免这种情况。

将 sheet 水平合并为一个 sheet

Combine sheets into one sheet horizontally

excel

vba

spreadsheet