将 n 张纸并排合并在一张纸上

Question

我想将几张 Excel 工作表合二为一。这些应该并排粘贴。

例如 sheet1-table A 到 D， sheet2-table E 到 G， sheet3-table H 到 J，等等。

（不同大小的）表格没有并排粘贴。

我找到了代码并尝试调整它：

Sub CombineSheetsNextToEachOther()
On Error GoTo eh
'declare variables to hold the objects required
   Dim wbDestination As Workbook
   Dim wbSource As Workbook
   Dim wsDestination As Worksheet
   Dim wb As Workbook
   Dim sh As Worksheet
   Dim strSheetName As String
   Dim strDestName As String
   Dim iRws As Integer
   Dim iCols As Integer
   Dim totRws As Integer
   Dim totCols As Integer
   Dim strEndRng As String
   Dim rngSource As Range
'turn off the screen updating to speed things up
   Application.ScreenUpdating = False
'first create new destination workbook
   Set wbDestination = Workbooks.Add
'get the name of the new workbook so you exclude it from the loop below
   strDestName = wbDestination.Name
'now loop through each of the workbooks open to get the data
   For Each wb In Application.Workbooks
      If wb.Name <> strDestName And wb.Name <> "PERSONAL.XLSB" Then
         Set wbSource = wb
         For Each sh In wbSource.Worksheets
'get the number of rows and columns in the sheet
            sh.Activate
            ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Activate
            iRws = ActiveCell.Row
            iCols = ActiveCell.Column
'set the range of the last cell in the sheet
            strEndRng = sh.Cells(iRws, iCols).Address
'set the source range to copy
            Set rngSource = sh.Range("A1:" & strEndRng)
'find the last column in the destination sheet
           wbDestination.Activate
           Set wsDestination = ActiveSheet
           wsDestination.Cells(1, Columns.Count).End(xlToLeft).Select
           totCols = ActiveCell.Column
'add a column to paste on the next column right
           If totCols <> 1 Then totCols = totCols + 1
           rngSource.Copy Destination:=wsDestination.Range("A" & totCols)
      Next sh
   End If
   Next wb
'now close all the open files except the one you want
   For Each wb In Application.Workbooks
      If wb.Name <> strDestName And wb.Name <> "PERSONAL.XLSB" Then
         wb.Close False
      End If
   Next wb
'clean up the objects to release the memory
   Set wbDestination = Nothing
   Set wbSource = Nothing
   Set wsDestination = Nothing
   Set rngSource = Nothing
   Set wb = Nothing
'turn on the screen updating when complete
   Application.ScreenUpdating = False
Exit Sub
eh:
MsgBox Err.Description
End Sub

Answer 1

你的代码只有一个错误。

代码行 44 rngSource.Copy Destination:=wsDestination.Range("A" & totCols) 将数据粘贴到“A”列、“totCols”行——这与您想要的相反。

您应该使用rngSource.Copy Destination:=wsDestination.Cells(1, totCols)。

在第二个版本中，您使用的是“1”行和“totCols”列，这是一个动态数字，表示要粘贴信息的下一列。

请在下面找到完整的代码，对我来说运行良好：

Sub CombineSheetsNextToEachOther()
On Error GoTo eh
'declare variables to hold the objects required
   Dim wbDestination As Workbook
   Dim wbSource As Workbook
   Dim wsDestination As Worksheet
   Dim wb As Workbook
   Dim sh As Worksheet
   Dim strSheetName As String
   Dim strDestName As String
   Dim iRws As Integer
   Dim iCols As Integer
   Dim totRws As Integer
   Dim totCols As Integer
   Dim strEndRng As String
   Dim rngSource As Range
'turn off the screen updating to speed things up
   Application.ScreenUpdating = False
'first create new destination workbook
   Set wbDestination = Workbooks.Add
'get the name of the new workbook so you exclude it from the loop below
   strDestName = wbDestination.Name
'now loop through each of the workbooks open to get the data
   For Each wb In Application.Workbooks
      If wb.Name <> strDestName And wb.Name <> "PERSONAL.XLSB" Then
         Set wbSource = wb
         For Each sh In wbSource.Worksheets
'get the number of rows and columns in the sheet
            sh.Activate
            ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Activate
            iRws = ActiveCell.Row
            iCols = ActiveCell.Column
'set the range of the last cell in the sheet
            strEndRng = sh.Cells(iRws, iCols).Address
'set the source range to copy
            Set rngSource = sh.Range("A1:" & strEndRng)
'find the last column in the destination sheet
           wbDestination.Activate
           Set wsDestination = ActiveSheet
           wsDestination.Cells(1, Columns.Count).End(xlToLeft).Select
           totCols = ActiveCell.Column
'add a column to paste on the next column right
           If totCols <> 1 Then totCols = totCols + 1
           rngSource.Copy Destination:=wsDestination.Cells(1, totCols)
      Next sh
   End If
   Next wb
'now close all the open files except the one you want
   For Each wb In Application.Workbooks
      If wb.Name <> strDestName And wb.Name <> "PERSONAL.XLSB" Then
         wb.Close False
      End If
   Next wb
'clean up the objects to release the memory
   Set wbDestination = Nothing
   Set wbSource = Nothing
   Set wsDestination = Nothing
   Set rngSource = Nothing
   Set wb = Nothing
'turn on the screen updating when complete
   Application.ScreenUpdating = False
Exit Sub
eh:
MsgBox Err.Description
End Sub