Sub blanks_and_stuff()
Dim r&, c&, i&, j&, k&, a, u()
r = Cells.Find("*", , , , xlByRows, xlPrevious).Row
c = Cells.Find("*", , , , xlByColumns, xlPrevious).Column
For j = 1 To c Step 2
    a = Cells(2, j).Resize(r)
    ReDim u(1 To r, 1 To 1)
    For i = 1 To r - 1
        If Len(a(i, 1)) = 0 Then
            k = k + 1
        Else
            If k > 0 Then u(i, 1) = k: k = 0
        End If
    Next i
    Cells(2, j + 1).Resize(r) = u
    If Len(a(1, 1)) = 0 Then Cells(j + 1).End(4) = "#NA"
    k = 0
Next j
End Sub