Schleife über Spalten

Hallo alle zusammen,
ich würde gerne die Zeile 17 Spalte für Spalte durchgehen und wann immer da ein Wert drin steht, den Bereich 18:5000 als Named Range definieren, wobei der Name in Zeile 17 steht.
Jetzt ist mein Code allerdings absolutes Harakiri. Könntet ihr mir da helfend zur Hand gehen?

Sub Namen()
Dim intCol As Integer
intCol = 1
If Not IsEmpty(Cells(17, intCol)) Then
Do While Len(Cells(18, intCol).Formula) > 0
With Sheets("Tabelle2")
.Range(.Cells(18, intCol), .Cells(5000, intCol)).Name = .Range(.Cells(17, intCol))
intCol = intCol + 1
End With
Loop
Else
intCol = intCol + 1
End If
End Sub