The code below creates an ID number in column A of the worksheet when an
entry is made/copied into column B of the same row.

The first row is made up of column headings. It works fine when more than
one row of data is copied into B2 but if only one row is copied then it goes
pear shaped.

Private Sub Worksheet_Change(ByVal Target As Excel.Range)
'ID number
Dim rng As Range, rng1 As Range
Dim cell As Range, val As Long
Dim rngB As Range
On Error GoTo errhandler
If Target.Column = 2 Then
Application.EnableEvents = False
Set rngB = Range("B2:B" & Range("B" & Rows.Count).End(xlUp).Row)
Set rng = rngB.Offset(0, -1)
val = Application.Max(rng)
If Intersect(rng, Cells(1, 1)) Is Nothing Then
On Error Resume Next
Set rng1 = rng.SpecialCells(xlBlanks)
On Error GoTo errhandler
If Not rng1 Is Nothing Then
For Each cell In rng1
val = val + 1
cell.Formula = val
Next
End If
End If
End If
errhandler:
Application.EnableEvents = True
End Sub

I had help with the code from this group so don't even know how it works let
alone try to amend it.

Hope someone can help.

Thanks in advance.

Gareth

Gareth

Try this:

Private Sub Worksheet_Change(ByVal Target As Excel.Range)
'ID number
Dim rng As Range, rng1 As Range
Dim cell As Range, val As Long
Dim rngB As Range
On Error GoTo errhandler
If Target.Column = 2 Then
Application.EnableEvents = False
Set rngB = Range("B2:B" & Range("B" & Rows.Count).End(xlUp).Row)
Set rng = rngB.Offset(0, -1)
val = Application.Max(rng)
If Intersect(rng, Cells(1, 1)) Is Nothing Then
On Error Resume Next
Set rng1 = Intersect(rng.SpecialCells(xlBlanks), Range("A:A")) '
<<<<
On Error GoTo errhandler
If Not rng1 Is Nothing Then
For Each cell In rng1
val = val + 1
cell.Formula = val
Next
End If
End If
End If
errhandler:
Application.EnableEvents = True
End Sub

Regards

Trevor


"Gareth" wrote in message
...
The code below creates an ID number in column A of the worksheet when an
entry is made/copied into column B of the same row.

The first row is made up of column headings. It works fine when more than
one row of data is copied into B2 but if only one row is copied then it
goes
pear shaped.

Private Sub Worksheet_Change(ByVal Target As Excel.Range)
'ID number
Dim rng As Range, rng1 As Range
Dim cell As Range, val As Long
Dim rngB As Range
On Error GoTo errhandler
If Target.Column = 2 Then
Application.EnableEvents = False
Set rngB = Range("B2:B" & Range("B" & Rows.Count).End(xlUp).Row)
Set rng = rngB.Offset(0, -1)
val = Application.Max(rng)
If Intersect(rng, Cells(1, 1)) Is Nothing Then
On Error Resume Next
Set rng1 = rng.SpecialCells(xlBlanks)
On Error GoTo errhandler
If Not rng1 Is Nothing Then
For Each cell In rng1
val = val + 1
cell.Formula = val
Next
End If
End If
End If
errhandler:
Application.EnableEvents = True
End Sub

I had help with the code from this group so don't even know how it works
let
alone try to amend it.

Hope someone can help.

Thanks in advance.

Gareth