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

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

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

我想要做的是创build一个VBAmacros，为每一系列数据创build一个新的工作表（一系列从“分隔符”开始，在下一个或最初的工作表的末尾结束），并将相应的数据新的床单。 例：

 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

试试这个…（未testing）

 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