Option Explicit
Sub addNum()
Dim myRng As Range, i As Long, cell As Range, lRow As Long, subRngs() As String, tStart As String, tEnd As String
Dim nbrs() As Long, x As Long, nbr
lRow = Me.UsedRange.Rows.Count
Set myRng = Me.Range(Cells(1, 2), Cells(lRow, 2))
For Each cell In myRng
If cell.Row = lRow Then
tEnd = cell.Address
ReDim Preserve subRngs(i)
subRngs(i) = Range(tStart & ":" & tEnd).Address
tStart = cell.Address
i = i + 1
End If
If WorksheetFunction.IsText(cell.Value) Then
Select Case tStart
Case Is <> Empty
tEnd = cell.Offset(-1, 0).Address
Case Is = ""
tStart = cell.Address
End Select
If Not tStart = "" And Not tEnd = "" Then
ReDim Preserve subRngs(i)
subRngs(i) = Range(tStart & ":" & tEnd).Address
tStart = cell.Address
i = i + 1
End If
ElseIf WorksheetFunction.IsNumber(cell.Value) Then
ReDim Preserve nbrs(x)
nbrs(x) = cell.Value
x = x + 1
End If
Next cell
For i = 0 To UBound(subRngs)
Range(subRngs(i)).Offset(0, -1) = nbrs(i)
Next i
End Sub
