VB Script Error

[philmatth]

I'm having a problem with a VB script which was kindly posted for me some time ago and has functioned perfectly until I've tried it on the sheet below. The highlighted fields should be removed when the macro is run and the associated image names should be moved to the adjacent fields.



The script does move the image names for the first three duplicate prod-id's but doesn't remove the highlighted cells and gives the error below:

Set nRng = Union(nRng, .Item(k).Offset(1).Resize(.Item(k).Count - 1))

Here's the VBscript:

Sub ImageManip
Dim Rng As Range
Dim Dn As Range
Dim k
Dim nRng As Range
Dim Temp As Range
Set Rng = Range(Range("A1"), Range("A" & Rows.Count).End(xlUp))
With CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
For Each Dn In Rng
If Not .Exists(Dn.Value) Then
.Add Dn.Value, Dn
Else
Set .Item(Dn.Value) = Union(.Item(Dn.Value), Dn)
End If
Next

For Each k In .keys
If .Item(k).Count > 1 Then
If nRng Is Nothing Then
Set Temp = .Item(k)(1).Offset(, 1)
Set nRng = .Item(k).Offset(1).Resize(.Item(k).Count - 1)
Else
Set Temp = .Item(k)(1).Offset(, 1)
Set nRng = Union(nRng, .Item(k).Offset(1).Resize(.Item(k).Count - 1))
End If
Temp.Resize(, .Item(k).Count) = Application.Transpose(.Item(k).Offset(, 1).Value)
End If
Next k
nRng.EntireRow.Delete
End With
End Sub

Any help at all would be much appreciated.

 

[philmatth]

Mick - many many thanks - that's sorted it perfectly