Thanx for that one lucas (another for the old memory bank ) but once Tony pointed out my mistake of not having a header row I changed it to the following and it worx fine now
Sub ShowForm()
If ActiveSheet.Range("A1") = Empty Then GoTo ErrorMsg
'//count number of data fields
ActiveSheet.Range("A1").Select
NumColumns = 1
Do While Selection.Value <> ""
Selection.Offset(0, 1).Select
NumColumns = NumColumns + 1
Loop
'//find empty row
With ActiveSheet.Range("A:A")
Set FromOrigin = .Find("", LookIn:=xlValues)
End With
'//enter data
For Y = 0 To 65000
For X = 0 To NumColumns - 2
With ActiveSheet
FromOrigin.Offset(Y, X).Select
Heading = ActiveSheet.Range("A1").Offset(0, X)
DataIs = Application.InputBox(prompt:="Type in " & Heading & " and hit Enter - leave blank or click Cancel to Exit", Title:=Heading, Type:=2)
If DataIs = Empty Then End
Selection.Value = DataIs
End With
Next X
Next Y
Exit Sub
ErrorMsg: MsgBox "You need headings/labels in the 1st row that describe all your data fields", vbOKOnly, "HEADINGS NEEDED FIRST..."
End Sub