用分隔符複製新表格中的單元格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