Copy cells in a new sheet by separator VBA

1
votes

I have this problem in Excel that I want to solve using Macros in VBA. I have a sheet that contains data in this format: 

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

What I want to do is to create a VBA macro that creates a new sheet for every series of data (a series starts from the "separator" and ends before the next one or at the end of the initial sheet) and copy respective data in the new sheets. Example:

1
2
6
3
8
342
532

in sheet1

72
28
10
21

in sheet2 etc. Thank you very much, I appreciate it! This copies data from beginning to the first separator ("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
2
vbaexcel
What I want to do is to create a VBA macro that creates a new sheet for every series of data... Kool! Can you show us what have you tried till now and where exactly are you getting the error? – Siddharth Rout
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 The separator is "q" and this only creates a new sheet (sheet2) and adds all data until the first "q" in that sheet. Next? – BVdjV
Can you update your question with the code. It is really difficult to read code in comments... – Siddharth Rout
Done! updated the question – BVdjV

2 Answers

1
votes

Try this... (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
votes

You could use this to avoid Looping every row. As long as you want to delete the original data as well. 

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