OK


With your original data this will present as you wanted. I misunderstood
before.

Sub CreateList2()
' select Both columns
' make sure columns c .... z are blank
r = ActiveCell.Row - 1: col = ActiveCell.Column
nr = Selection.Rows.Count
For Each c In Selection
If IsEmpty(c) Then
'Do nothing
ElseIf IsNumeric(c) Then
Count = 0
col = 1: r = r + 1
Cells(r, col) = c:
ElseIf Not IsNumeric(c) Then
Count = Count + 1
If Count 1 Then
r = r + 1
End If
Cells(r, col + 1) = c
Cells(r, col + 2) = Count
End If
Next
'remove data from remaining rows
Range(Cells(r + 1, 1), Cells(nr + 1, 2)).ClearContents
'remove selection
Range("A1").Select
End Sub

Regards
Peter

"Witold" wrote:

How obvious! But it leaves empty row every couple of rows. Any way to
remove them quickly?

Thanks