在新工作表中复制和粘贴行

Question

我在将行从多张工作表复制到新工作表时遇到问题。我现在的代码如下：

     Sub Samenvoegen()

 Dim J As Integer


On Error Resume Next
Sheets(1).Select
Worksheets.Add ' add a sheet in first place
Sheets(1).Name = "Index"

' work through sheets
For J = 2 To Sheets.Count ' from sheet 2 to last sheet
    Sheets(J).Activate ' make the sheet active
    Range("2:2").Select
    Range(Selection, Cells(Rows.Count, "2:2").End(xlUp)).Copy Range("2:2") ' select all cells in this sheets

    ' select all lines except title
    Selection.Offset(1, 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

例如：我的 excel 文件中有 10 个工作表，如果我使用此宏，它会将所有这些 excel 工作表的第 2 行合并到 1 个名为“索引”的工作表中，并将每个工作表粘贴到彼此下方。这就是我想要的。但是这个宏的问题是它正确地从第一个工作表中复制了第二行。但是在第一个工作表之后，它从第二个工作表的 B2 和第三个工作表的 C2 复制，依此类推..

我想要一个宏，它从工作表中复制所有第二行并将其粘贴到彼此下方的新工作表中。我在这里做错了什么？

Answer 1

Sub Samenvoegen()

    Dim ws As Worksheet, wb As Workbook, i As Long

    Set wb = ThisWorkbook
    wb.Sheets.Add ' add a sheet in first place
    wb.Sheets(1).Name = "Index"
    
    ' work through sheets
    i = 1
    For Each ws In wb.Sheets ' from sheet 2 to last sheet
        If ws.Name <> "Index" Then
            ' copy row(2) into the new sheet
            ws.Rows(2).Copy 
            wb.Sheets("Index").Range("A" & i).PasteSpecial xlPasteValues
            i = i + 1
        End If
    Next
End Sub