Split data by blank row and rename new sheets by cell value from original dataset
I have the following data in Sheet1
with headers as you can see below:
I want to split a large dataset into different sheets with each blank row . Each dataset is separated by an empty row, and each dataset has values in all cells in columns A and E , but their columns B , C , D may be random empty cells. Thus, the determining element for separating the blank lines are in a column E .
Q1: I want to copy titles A1: D1 for new sheets and only copy columns A: D , instead of the column E .
Q2:I want to rename the new sheets to take the value of the cell in column E as my name.
So the results * are as follows:
Sheet ID1
:
Sheet ID2
: 
Sheet ID3
:
I tried the following code, it works, but it only copies the first table without renaming the sheet to take the value of the cell in column E, and it has to copy column E so that it only has to copy A: D and it doesn't go 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 greatly appreciated.
source to share
I took a slightly different approach, but I 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 reuse and the number of data blocks is counted by counting the separator blank lines and adding 1. The value from column E is used to rename the sheet, but is not carried over to the new worksheet during data transfer.
I'm not sure how you want to handle a worksheet with the same name that already exists, but they can be deleted before the new sheet is renamed.
source to share