首页 文章

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

提问于
浏览 次
1

我在Excel中有这个问题，我想在VBA中使用宏来解决 . 我有一张包含以下格式的数据：

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

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

1
2
6
3
8
342
532

在sheet1中

72
28
10
21

在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
excel vba excel-vba

2 回答

  • 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
    回复于
  • 0

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

    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
    回复于

相关问题