vba - 在 Excel 中自动复制和粘贴特定范围的最佳方法是什么？

Question

我对 VBA 很陌生，有一个任务我想自动化但不知道从哪里开始。我有一个如下所示的数据集。

Sample Data

我正在尝试做的是遍历 A 列，如果其中有某些内容(始终是电子邮件)，则选择所有行，直到 A 列中再次出现某些内容。复制并粘贴到新标签中。因此，第 2-5 行将复制并粘贴到新选项卡中。然后将第 6-9 行放入另一个新选项卡。第 1 行也将复制到每个选项卡。我一直无法找到代码来帮助满足这一特定需求，任何帮助将不胜感激。

我找到了这段代码并开始修改它，但是它与我需要或为此工作的东西相去甚远。

Sub split()

Dim rng As Range
Dim row As Range

Set rng = Range("A:A")

For Each row In rng
    'test if cell is empty
    If row.Value <> "" Then
        'write to adjacent cell
        row.Select
        row.Copy
        Worksheets("Sheet2").Activate
        Range("A2").Select
        row.PasteSpecial
        Worksheets("Sheet1").Activate
    End If
Next
End Sub

Answer 1

此代码应提供您需要的内容:

Sub Split()

Dim wb As Workbook
Set wb = ThisWorkbook

Dim ws As Worksheet
Set ws = wb.Worksheets(1) 'change sheet index or use Worksheets("Sheet1") method to use exact name

Dim rngBegin As Range
Dim rngEnd As Range

With ws

    Dim rngHeader As Range
    Set rngHeader = .Range("A1:H1") 'to copy headers over each time

    Dim lRowFinal As Long
    lRowFinal = .Range("C" & .Rows.Count).End(xlUp).Row 'assumes eventually last row of needed data will have an address1

    Set rngEnd = .Range("A1") ' to begin loop
    Set rngBegin = rngEnd.End(xlDown) 'to begin loop

    Do

        Set rngEnd = rngBegin.End(xlDown).Offset(-1)

        Dim wsNew As Worksheet
        Set wsNew = Worksheets.Add(After:=wb.Sheets(.Index))'always after current sheet, change as needed

        .Range(.Cells(rngBegin.Row, 1), .Cells(rngEnd.Row, 8)).Copy wsNew.Range("A2")
        wsNew.Range("A1:H1").Value = rngHeader.Value

        Set rngBegin = rngEnd.End(xlDown)

    Loop Until rngBegin.Row >= lRowFinal

End With

End Sub