Added check for only single row
(Suggestion / Tip: BTW, it's not always necessary to [Reply With Quote]. Sometimes I do if multple members are posting so that my answer goes to the correct person, but I usually edit out the oft times lengthy code that was in the quoted post)
Any issues, question, or special conditions (e.g. 1 row) please feel free to come back
Option Explicit
Sub Cleanup()
Dim rFirst As Range, rLast As Range, rEnd As Range, rData As Range, rArea As Range
Dim rBlanks As Range
Dim iArea As Long
Dim sHeading As String
Application.ScreenUpdating = False
'find data
With Worksheets("Test")
' With ActiveSheet
' With Worksheets("Whatever it is named")
Set rFirst = .Cells(7, 2)
Set rLast = .Cells(.Rows.Count, 2).End(xlUp)
Set rEnd = .Cells(rLast.Row, .Columns.Count).End(xlToLeft)
Set rData = Range(rFirst, rEnd)
'MsgBox rData.Address
Set rBlanks = rData.Columns(1).SpecialCells(xlCellTypeBlanks)
'MsgBox rBlanks.Address
For iArea = 1 To rBlanks.Areas.Count
With rBlanks.Areas(iArea)
Set rFirst = .Offset(1, 0)
sHeading = rFirst.Value
Set rFirst = rFirst.Offset(2, 0)
'only single row of data since the next row/cell is blank <<<<<<<<<<<<<<<<<<<<<<<<<<<<
If Len(rFirst.Offset(1, 0).Value) = 0 Then
Set rLast = rFirst
Else
Set rLast = rFirst.End(xlDown)
Set rEnd = rLast.End(xlToRight).Offset(0, 1)
End If
Set rEnd = rLast.End(xlToRight).Offset(0, 1)
Set rArea = Range(rFirst, rEnd)
rArea.Columns(rArea.Columns.Count).Value = sHeading
End With
Next iArea
'best to go bottoms up
For iArea = rBlanks.Areas.Count To 2 Step -1
With rBlanks.Areas(iArea)
' MsgBox .EntireRow.Resize(3).Address
.EntireRow.Resize(3).Delete
End With
Next iArea
'special treatment for first block
With rBlanks.Areas(1)
.Offset(1, 0).EntireRow.Delete
.Offset(1, 0).End(xlToRight).Offset(0, 1).Value = "HEADING"
End With
On Error GoTo 0
.ListObjects.Add(xlSrcRange, rBlanks.Areas(1).Offset(1, 0).CurrentRegion, , xlYes).Name = "Table1"
End With
Application.ScreenUpdating = True
MsgBox "Done"
End Sub