用分隔符复制新表格中的单元格VBA

Question

我在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 

Answer 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 

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