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

【问题标题】：Copy cells in a new sheet by separator VBA通过分隔符VBA复制新工作表中的单元格
【发布时间】：2013-09-28 14:51:35
【问题描述】：

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

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

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

在工作表 1 中

在 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

【问题讨论】：

What I want to do is to create a VBA macro that creates a new sheet for every series of data... 酷！你能告诉我们你到目前为止都尝试了什么，你到底在哪里得到错误？
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 分隔符是“q”，这只会创建一个新工作表 (sheet2) 并添加所有数据，直到该工作表中的第一个“q”。下一个？
你能用代码更新你的问题吗？ cmets中的代码真的很难看懂……
完成！更新了问题

标签： vba excel

【解决方案1】：

试试这个...（未测试）

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

【讨论】：

【解决方案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

【讨论】：