将多张图纸中的所有数据复制到一张新图纸中

Question

我的情况是：我想从多个excel表中复制表，并将其合并到一个新表中。到目前为止，我的宏确实选择了表，并创建了一个新的工作表来组合数据，但在组合时它没有选择表的最后一行。感谢您的帮助：

 Sub Trytocombine()
 Dim J As Integer

On Error Resume Next
Sheets(1).Select
Worksheets.Add ' add a sheet in first place
Sheets(1).Name = "For Drafting"
' copy headings
Sheets(2).Activate
Range("A1").EntireRow.Select
Selection.CurrentRegion.Select
Selection.Copy Destination:=Sheets(1).Range("A1")
' work through sheets
For J = 2 To Sheets.Count ' from sheet 2 to last sheet
    Sheets(J).Activate ' make the sheet active
    Range("A1").Select
    Selection.CurrentRegion.Select ' select all cells in this sheets
    ' select all lines except title
    Selection.Offset(0, 0).Resize(Selection.Rows.Count - 1).Select
    ' copy cells selected in the new sheet on last line
    Selection.Copy Destination:=Sheets(1).Range("A65536").End(xlUp)(2)
Next
End Sub

Answer 1

重新生成以避免选择（并在最后一行之后复制）：

Sub Combine()
Worksheets.Add ' add a sheet in first place
Sheets(1).Name = "For Drafting"
' copy headings
Sheets(1).Range("A1").EntireRow.Value = Sheets(2).Range("A1").EntireRow.Value 'not most effecient, but will do for this
' work through sheets
Dim J As Integer
For J = 2 To Sheets.Count ' from sheet 2 to last sheet
    With Sheets(J)
        .Range(.Cells(2,1),.Cells(.Range("A" & .Rows.Count).End(xlUp).Row,.Cells(2,.Columns.Count).End(xlToLeft).Column)).Copy _ 
             Sheets(1).Range("A" & Rows.Count).End(xlUp).Offset(2)
    End With
Next
End Sub