Sub MergeNonEmptyCells()
Dim ws As Worksheet
Dim startRow As Long
Dim lastRow As Long
Set ws = ThisWorkbook.Worksheets("Sheet1")
startRow = 1
lastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row
Dim i As Long
For i = startRow To lastRow
If ws.Cells(i, "A").Value = "" Then
ws.Range("A" & startRow & ":A" & i).Merge
Else
startRow = i
End If
Next i
End Sub
