Sub SimpleOutline()
Dim Dic As Object
Dim b As Long, _
rwLast As Long
Dim c As Range
Dim arRows()
Dim i As Integer, _
j As Integer
Dim strTemp As String
'clear the outline if it exists
On Error Resume Next
Columns("A:A").ClearOutline
On Error GoTo 0
rwLast = Range("B" & Rows.Count).End(xlUp).Row + 1
Set Dic = CreateObject("Scripting.Dictionary")
'use the Dictionary object to build an array of cell addresses
For Each c In Range("A:A").SpecialCells(xlCellTypeConstants)
b = b + 1
Dic.Add c.Row, b
Next c
Dic.Add rwLast, b + 1
arRows = Dic.keys
Set Dic = Nothing
' 'testing
' Range("J1").Resize(b, 1) = WorksheetFunction.Transpose(arRows)
For i = LBound(arRows) To UBound(arRows) - 1
j = i + 1
strTemp = "A" & arRows(i) + 1 & ":A" & arRows(j) - 1
' Debug.Print strTemp
Range(strTemp).Rows.Group
Next i
End Sub