Question

我在Excel中遇到此问题，我想在VBA中使用宏来解决。我有一张包含以下格式的数据的表格：

separator
1
2
6
3
8
342
532
separator
72
28
10
21
separator
38
23
234

我想要做的是创建一个VBA宏，为每个数据系列创建一个新工作表（一系列从“分隔符”开始，在下一个或在初始工作表结束之前结束）并复制新表中的相应数据。例如：

在sheet1中

in sheet2等非常感谢，我很感激！这会将数据从头开始复制到第一个分隔符（“q”）：

Sub macro1()
Dim x As Integer
x = 1

Sheets.Add.Name = "Sheet2"

'Get cells until first q

Do Until Sheets("Sheet1").Range("A" & x).Value = "q"
Sheets("Sheet2").Range("A" & x).Value = Sheets("Sheet1").Range("A" & x).Value
x = x + 1
Loop


End Sub

Answer 1

试试这个......（UNTESTED）

Const sep As String = "q"

Sub Sample()
    Dim ws As Worksheet, wsNew As Worksheet
    Dim lRow As Long, i As Long, rw As Long

    '~~> Set this to the relevant worksheet
    Set ws = ThisWorkbook.Sheets("Sheet1")
    '~~> Add a new temp sheet
    Set wsNew = ThisWorkbook.Sheets.Add

    '~~> Set row for the new output sheet
    rw = 1

    With ws
        '~~> Get the last row
        lRow = .Range("A" & .Rows.Count).End(xlUp).Row

        '~~> Loop through the cells from row 2
        '~~> assuming that row 1 has a spearator
        For i = 2 To lRow
            If .Range("A" & i).Value = sep Then
                Set wsNew = ThisWorkbook.Sheets.Add
                rw = 1
            Else
                wsNew.Cells(rw, 1).Value = .Range("A" & i).Value
                rw = rw + 1
            End If
        Next i
    End With
End Sub

Answer 2

您可以使用它来避免每行循环。只要你想删除原始数据。

SubSample()
Dim x As Integer
Dim FoundCell As Range
Dim NumberOfQs As Long
Dim SheetWithData As Worksheet
Dim CurrentData As Range

Set SheetWithData = Sheets("Sheet4")
NumberOfQs = WorksheetFunction.CountIf(SheetWithData.Range("A:A"), "q")

x = 1


Set FoundCell = SheetWithData.Range("A1", SheetWithData.Range("A" & Rows.Count)).Find("q", , , , , xlPrevious)

If Not FoundCell Is Nothing Then
    Set LastCell = FoundCell.End(xlDown)
    Set CurrentData = SheetWithData.Range(FoundCell, LastCell)
    Sheets.Add.Name = "QSheetNumber" & x 'Get cells until first q
    CurrentData.Cut Sheets("QSheetNumber" & x).Range("A1")
    Sheets("QSheetNumber" & x).Rows(1).Delete
    x = x + 1
    Set FoundCell = SheetWithData.Range("A1", SheetWithData.Range("A" & Rows.Count)).Find("q", FoundCell, , , , xlPrevious)
    If Not FoundCell Is Nothing Then
        Set LastCell = FoundCell.End(xlDown)
        Set CurrentData = SheetWithData.Range(FoundCell, LastCell)
        Sheets.Add.Name = "QSheetNumber" & x 'Get cells until first q
        CurrentData.Cut Sheets("QSheetNumber" & x).Range("A1")
        Sheets("QSheetNumber" & x).Rows(1).Delete
        x = x + 1
    Else
        Exit Sub
    End If
Else
    Exit Sub
End If

End Sub

通过分隔符VBA复制新工作表中的单元格

2 个答案: