如何将行从一个 Excel 工作表复制到另一个工作表并使用 VBA 创建重复项？

Posted 2023-02-14

【中文标题】如何将行从一个 Excel 工作表复制到另一个工作表并使用 VBA 创建重复项？

【英文标题】：How can I copy rows from one Excel sheet to another and create duplicates using VBA?

【发布时间】：2012-10-01 23:37:03

【问题描述】：

我有一个包含两张工作表的 Excel 工作簿：sheet1 在 A 到 R 列中有一个大数据表，在第 1 行有标题。Sheet2 在 A 到 AO 列中有数据。

使用 VBA 我试图从 sheet1 复制行并将它们粘贴到 sheet2 的末尾。此外，我只需要将 A 列复制到 R，而不是整行。

换句话说，需要将 sheet1 中的单元格 A2:R2 复制到 A 列中没有数据的第一行和第二行。

我有以下代码从 sheet1 复制所需的单元格，但我不知道如何将每一行复制两次：

Sub example()
    For Each ce In Range("A2:A" & Cells(Rows.Count, 1).End(xlUp).Row)
        If Not IsEmpty(ce) Then
            Sheets("sheet2").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Resize(1, 18).Value = Range(ce, ce.Offset(0, 17)).Value
        End If
    Next ce
End Sub

【参考方案1】：

试试这个：

Option Explicit
Sub CopyRows()
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim i As Integer, k As Integer
    Dim ws1LR As Long, ws2LR As Long

    Set ws1 = Sheets("Sheet1")
    Set ws2 = Sheets("Sheet2")

    ws1LR = ws1.Range("A" & Rows.Count).End(xlUp).Row + 1
    ws2LR = ws2.Range("A" & Rows.Count).End(xlUp).Row + 1

    i = 2
    k = ws2LR
    Do Until i = ws1LR
        With ws1
            .Range(.Cells(i, 1), .Cells(i, 18)).Copy
        End With

        With ws2
            .Cells(k, 1).PasteSpecial
            .Cells(k, 1).Offset(1, 0).PasteSpecial
        End With

        k = k + 2
        i = i + 1
    Loop
End Sub

如果 Sheet1 和 Sheet2 在您的工作簿中被称为不同的东西，请更改它们。

【讨论】：

非常感谢！似乎运行完美，除了它没有复制 sheet1 中的最后一个数据行。知道可能是什么问题吗？

将+1 添加到ws1LR = ... 行的末尾，与ws2LR 行相同。我已经编辑了我的帖子，如果答案对您有用，请点赞和/或接受:)

使用整数存储行号很危险，因为它们可能会溢出。请改用 long。