CODEWITHSUNDEEP
vbaexcel
cplus
cplus

Reputation: 1115

Split data by empty row and rename the new sheets by cell value from the original data set

I have the following data set in Sheet1 with headings as you see below:

enter image description here

I want to split the big data set into different sheets by every empty row. Every data set is separated by an empty row, and every data set have values in all cells in columns A and E but their columns B, C, D might have some empty cells randomly. So the defining element to split is the empty rows in column E.
Q1: I want to copy the headings A1:D1 to the new sheets and only copy the columns A:D and not the column E.
Q2: I want to rename new sheets to take the cell value in column E as their name.

So the *results are the following:

Sheet ID1:

enter image description here



Sheet ID2:

enter image description here

Sheet ID3:

enter image description here



I have tried the following code, it works, but it only copies the first table, without renaming the sheet to take the cell value in column E, and it should copy the column E so it should copy only A:D, and it doesn't loop through all tables.

Sub Split_Sheets_by_row()
    Dim lLoop As Long, lLoopStop As Long
    Dim rMove As Range, wsNew As Worksheet

    Set rMove = ActiveSheet.UsedRange.Columns("A:E")
    lLoopStop = WorksheetFunction.CountIf(rMove, "Heading5")
    For lLoop = 1 To lLoopStop
        Set wsNew = Sheets.Add
        rMove.Find("Heading5", rMove.Cells(1, 1), xlValues, _
        xlPart, , xlNext, False).CurrentRegion.Copy _
        Destination:=wsNew.Cells(1, 1)
    Next lLoop
End Sub



Your help is very much appreciated.

Upvotes: 3

Views: 2770

Answers (1)

user4039065
user4039065

Reputation:

I've taken a slightly different approach but I have achieved the results you are looking for.

Sub Split_Sheets_by_row()
    Dim hdr As Range, rng As Range, ws As Worksheet, wsn As Worksheet
    Dim rw As Long, lr As Long, b As Long, blks As Long

    Set ws = ActiveSheet
    With ws
        Set hdr = .Cells(1, 1).Resize(1, 4)
        lr = .Cells(Rows.Count, 5).End(xlUp).Row
        rw = 2
        blks = Application.CountBlank(.Range(.Cells(rw, 1), .Cells(lr, 1))) + 1
        For b = 1 To blks
            Set rng = .Cells(rw, 1).CurrentRegion
            Set rng = rng.Offset(-CBool(b = 1), 0).Resize(rng.Rows.Count + CBool(b = 1), 4)
            Set wsn = Worksheets.Add(after:=Sheets(Sheets.Count))
            With wsn
                .Name = rng.Offset(0, 4).Cells(1, 1).Value
                hdr.Copy Destination:=.Cells(1, 1)
                rng.Copy Destination:=.Cells(2, 1)
            End With
            rw = rw + rng.Rows.Count + 1
            Set rng = Nothing
            Set wsn = Nothing
            If rw > lr Then Exit For
        Next b
    End With
    Set rng = Nothing
    Set ws = Nothing

End Sub

The header is stored for repeated use and the number of blocks of data are counted by counting the separating blank rows and adding 1. The value from column E is used to rename the worksheet but is not carried across in the data transfer to the new worksheet.

I'm not sure how you would want to handle a worksheet with the same name already existing but they could be deleted before a new worksheet is renamed.

Upvotes: 3

Related Questions