我有一个包含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
使用此代码，我所有工作表中的数据都会重叠。我希望数据在另一个之下。
答案 0 :(得分：0)
它重叠是因为您没有增加目标表上的粘贴区域
要解决问题，请相应地偏移粘贴区域：
你也可以替换它：
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"
如果你消除所有＆＃34;选择＆＃34;语句并明确引用每个对象，它将允许您减少代码和不必要的复杂性
这是我的版本：
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")