水平组合成一张纸

我想将工作簿中的所有工作表合并在一起。

我目前的代码如下所示：

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 

但是，我目前的输出是：

对于这个例子，我有三张纸，他们看起来像下面这样：

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

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

期望的输出

任何build议我做错了什么？

我感谢你的回答！

Answer 1

我写了这个，似乎工作得不错。 它假设您将始终从每个工作表中的相同范围（在strRangevariables中设置）进行复制。 我在testing中使用范围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中复制相同的数据，所以每次移动到新工作表时都可能不会改变它的select。 我有一段时间没有使用直接的select，所以我不知道哪个部分是造成它，但可以通过更复杂的数据直接与上面的rngPaste.Value = rngCopy.Value类似的rngPaste.Value = rngCopy.Value 。