合并多个工作表时的数据重叠

Question

我有一个包含n个工作表的Excel工作簿。我想将每张纸上的数据合并到一张纸上。来自第一张纸的页眉和数据应该在上面，第二张纸上的数据应该在下面，依此类推。所有工作表都具有相同的列和标题结构。所以，标题应该只出现一次，即从第一张表格获取标题和数据，并从剩余表格中获取数据。我有以下代码：

Sub Combine() 

'This macro will copy all rows from the first sheet 
'(including headers) 
'and on the next sheets will copy only the data 
'(starting on row 2) 

Dim i As Integer 
Dim j As Long 
Dim SheetCnt As Integer 
Dim lstRow1 As Long 
Dim lstRow2 As Long 
Dim lstCol As Integer 
Dim ws1 As Worksheet 

With Application 
    .DisplayAlerts = False 
    .EnableEvents = False 
    .ScreenUpdating = False 
End With 

On Error Resume Next 

'Delete the Target Sheet on the document (in case it exists) 
Sheets("Target").Delete 
'Count the number of sheets on the Workbook 
SheetCnt = Worksheets.Count 

'Add the Target Sheet 
Sheets.Add after:=Worksheets(SheetCnt) 
ActiveSheet.Name = "Target" 
Set ws1 = Sheets("Target") 
lstRow2 = 1 
'Define the row where to start copying 
'(first sheet will be row 1 to include headers) 
j = 1 

'Combine the sheets 
For i = 1 To SheetCnt 
    Worksheets(i).Select 

    'check what is the last column with data 
    lstCol = ActiveSheet.Cells(1, ActiveSheet.Columns.Count).End(xlToLeft).Column 

    'check what is the last row with data 
    lstRow1 = ActiveSheet.Cells(ActiveSheet.Rows.Count, "A").End(xlUp).Row 

    'Define the range to copy 
    Range("A2:G2" & j, Cells(lstRow1, lstCol)).Select 

    'Copy the data 
    Selection.Copy 
    ws1.Range("A2:G2" & lstRow2).PasteSpecial 
    Application.CutCopyMode = False 

    Selection.Offset(1, 0).Resize(Selection.Rows.Count - 1).Select 
    'Define the new last row on the Target sheet 
    lstRow2 = ws1.Cells(65535, "A").End(xlUp).Row + 1 


    'Define the row where to start copying 
    '(2nd sheet onwards will be row 2 to only get data) 
    j = 3 
Next 

With Application 
    .DisplayAlerts = True 
    .EnableEvents = True 
    .ScreenUpdating = True 
End With 

Sheets("Target").Select 
Cells.EntireColumn.AutoFit 
Range("A1").Select 

End Sub 

有了这段代码，我所有工作表中的数据都被重叠了。我希望数据是一个在另一个之下。

Answer 1

，因为你不增加对目标表

要解决该问题偏移粘贴区域对应粘贴区域这是重叠的：

1. 表1：复制10行粘贴 - >增量膏由
2. 表2开始&端区域：复制15行粘贴 - >增量膏通过开始&端区域：10 + 15等等...

你也可以更换此：

Sheets.Add after:=Worksheets(SheetCnt) 'Add the Target Sheet 
ActiveSheet.Name = "Target" 
Set ws1 = Sheets("Target") 

与此：

Set ws1 = Sheets.Add(after:=Worksheets(SheetCnt)) 'Add the Target Sheet 
ws1.Name = "Target" 

如果你消除所有的“选择”的语句，并指每个对象明确它可以让你减少代码，和不需要的复杂性

这是我的版本：

---

Option Explicit 

Public Sub Combine() 
    Const HEADR As Byte = 1 

    Dim i As Long, rngCurrent As Range 
    Dim ws As Worksheet, wsTarget As Worksheet 
    Dim lCol As Long, lCel As Range 
    Dim lRow As Long, toLRow As Long 

    With Application 
     .DisplayAlerts = False 
     .EnableEvents = False 
     .ScreenUpdating = False 
    End With 

    For Each ws In Worksheets 'Delete Target Sheet if it exists 
     With ws 
      If .Name = "Target" Then 
       .Delete 
       Exit For 
      End If 
     End With 
    Next 
    Set wsTarget = Worksheets.Add(After:=Worksheets(Worksheets.Count)) 
    wsTarget.Name = "Target" 

    Set lCel = GetMaxCell(Worksheets(1).UsedRange) 
    If lCel.Row > 1 Then 
     With Worksheets(1) 
      'Expected: all sheets will have the same number of columns 
      lCol = lCel.Column 
      lRow = HEADR 
      toLRow = HEADR 

      .Range(.Cells(HEADR, 1), .Cells(HEADR, lCol)).Copy 
      With wsTarget 
       .Range(.Cells(HEADR, 1), .Cells(HEADR, lCol)).PasteSpecial xlPasteAll 
      End With 
     End With 

     For i = 1 To Worksheets.Count 'concatenate data --------------------------- 
      Set lCel = GetMaxCell(Worksheets(i).UsedRange) 
      If lCel.Row > 1 Then 
       With Worksheets(i) 
        If .Name <> "Target" Then   'exclude the Target 
         toLRow = toLRow + lRow   'last row on Target 
         lRow = lCel.Row     'last row on current 
         Set rngCurrent = .Range(.Cells(HEADR + 1, 1), _ 
               .Cells(lRow, lCol)) 
         lRow = lRow - HEADR 
         With wsTarget 
          .Range(.Cells(toLRow, 1), _ 
            .Cells(toLRow + (lRow - HEADR), lCol)) = _ 
            rngCurrent.Value 
         End With 
        End If 
       End With 
      End If 
     Next '-------------------------------------------------------------------- 
     With wsTarget 
      .Columns.AutoFit 
      .Range("A1").Select 
     End With 
     With Application 
      .CutCopyMode = False 
      .DisplayAlerts = True 
      .EnableEvents = True 
      .ScreenUpdating = True 
     End With 
    End If 
End Sub 

---

Public Function GetMaxCell(Optional ByRef rng As Range = Nothing) As Range 

    'Returns the last cell containing a value, or A1 if Worksheet is empty 

    Const NONEMPTY As String = "*" 
    Dim lRow As Range, lCol As Range 

    If rng Is Nothing Then Set rng = Application.ActiveWorkbook.ActiveSheet.UsedRange 
    If WorksheetFunction.CountA(rng) = 0 Then 
     Set GetMaxCell = rng.Parent.Cells(1, 1) 
    Else 
     With rng 
      Set lRow = .Cells.Find(What:=NONEMPTY, LookIn:=xlFormulas, _ 
             After:=.Cells(1, 1), _ 
             SearchDirection:=xlPrevious, _ 
             SearchOrder:=xlByRows) 
      If Not lRow Is Nothing Then 
       Set lCol = .Cells.Find(What:=NONEMPTY, LookIn:=xlFormulas, _ 
              After:=.Cells(1, 1), _ 
              SearchDirection:=xlPrevious, _ 
              SearchOrder:=xlByColumns) 

       Set GetMaxCell = .Parent.Cells(lRow.Row, lCol.Column) 
      End If 
     End With 
    End If 
End Function 

'-------------------------------------------------------------------------------------- 

抵消粘贴区域是通过增加lRow和toLRow做

编辑：

如果您使用此代码，并要传输的所有数据单元格格式细胞取代此部分：

'copy data to Target sheet 
With wsTarget 
    .Range(.Cells(toLRow, 1), .Cells(toLRow + (lRow - HEADR), lCol)) = _ 
     rngCurrent.Value 
End With 

与此：

'copy data to Target sheet 
rngCurrent.Copy 
With wsTarget 
    With .Range(.Cells(toLRow, 1), .Cells(toLRow + (lRow - HEADR), lCol)) 
     .PasteSpecial xlPasteAll 
    End With 
End With 

但如果你处理很多张

编辑它会越来越慢：显示如何处理特殊情况

上述解决方案更通用并动态检测最后一列和包含数据的行

要处理的列（和行）的数量可以手动更新。例如，如果你的表包含43列数据，并且要排除的最后2列，进行以下更改到脚本：

线

Set lCel = GetMaxCell(Worksheets(1).UsedRange)

变化

Set lCel = Worksheets(1).UsedRange("D41")