合併多個工作表時的數據重疊

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")