将纸张水平组合成一张纸

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

我写了这个，似乎运作得很好。它假设您将始终从每张表中的相同范围进行复制（在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更直接地复制数据来避免这种情况。