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

Question

I have the following data set in Sheet1 with headings as you see below:
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:
Sheet ID2:
Sheet ID3:
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.

Answer 1

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.