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.

 

[MickG]

Unfortunately, because you have posted the data as an image, it can't be copied to a test sheet, but after running the code against similar data, I can't get it to fail.
I should have another go on some different data see what happens.
The obvious line that could fail if there are no duplicates is :-"nRng.EntireRow.Delete" which should be changed to:-

If Not nRng Is Nothing Then nRng.EntireRow.Delete

Mick

 

[philmatth]

Hi Mick,
I still get the same error with that change so I went back to a sheet of data that does function.
So I changed the format of the product id's to this below and it worked.
25164
25165
25174
25196
25226
25226
25262
25262
25262
25262
25311
25311
25311
25312
25312
25312

But I really need it to function with the original ID's. Does this help at all?

 

[MickG]

Can you post you data so I can copy it.
If you place a border around each cell in the two columns to form a grid then copy and paste to the thread it should work.

 

[philmatth]

Sorry that didn't appear to work when I tested it.

Can you download it from here? - www dot autobitz dot co dot uk/test/book1.zip

Let me know when you're done so I can delet the file from the server

 

[MickG]

I've tried to copy from you original post and the code runs OK.
Your file link does not appear to relate to anything.
Can Just copy & paste the 2 columns to the forum.
Have you got any thing else below the Data that might cause a problem with the code

 

[philmatth]

It's rather a large amount of data but here are the first 20 lines - I didn't want the download link to get picked up by Google so I broke up the url
<table border="0" cellpadding="0" cellspacing="0" width="345"><col style="mso-width-source:userset;mso-width-alt:7241;width:149pt" width="198"> <col style="mso-width-source:userset;mso-width-alt:5376;width:110pt" width="147"> <tbody><tr style="height:12.75pt" height="17"> <td style="height:12.75pt;width:149pt" height="17" width="198">prodid</td> <td style="width:110pt" width="147">imgid</td> </tr> <tr style="height:12.75pt" height="17"> <td style="height:12.75pt" height="17">AhGoo-CP-CC</td> <td>giant/prodimages/17.jpg</td> </tr> <tr style="height:12.75pt" height="17"> <td style="height:12.75pt" height="17">AhGoo-CP-CC</td> <td>giant/prodimages/16.jpg</td> </tr> <tr style="height:12.75pt" height="17"> <td style="height:12.75pt" height="17">AhGoo-CP-CC</td> <td>giant/prodimages/15.jpg</td> </tr> <tr style="height:12.75pt" height="17"> <td style="height:12.75pt" height="17">AhGoo-CP-P</td> <td>giant/prodimages/4.jpg</td> </tr> <tr style="height:12.75pt" height="17"> <td style="height:12.75pt" height="17">AhGoo-CP-P</td> <td>giant/prodimages/5.jpg</td> </tr> <tr style="height:12.75pt" height="17"> <td style="height:12.75pt" height="17">AhGoo-CP-P</td> <td>giant/prodimages/6.jpg</td> </tr> <tr style="height:12.75pt" height="17"> <td style="height:12.75pt" height="17">AhGoo-CP-P</td> <td>giant/prodimages/7.jpg</td> </tr> <tr style="height:12.75pt" height="17"> <td style="height:12.75pt" height="17">AhGoo-CP-J</td> <td>giant/prodimages/8.jpg</td> </tr> <tr style="height:12.75pt" height="17"> <td style="height:12.75pt" height="17">AhGoo-CP-J</td> <td>giant/prodimages/9.jpg</td> </tr> <tr style="height:12.75pt" height="17"> <td style="height:12.75pt" height="17">AhGoo-CP-J</td> <td>giant/prodimages/10.jpg</td> </tr> <tr style="height:12.75pt" height="17"> <td style="height:12.75pt" height="17">Oopa-S-S-TB</td> <td>giant/prodimages/11.jpg</td> </tr> <tr style="height:12.75pt" height="17"> <td style="height:12.75pt" height="17">Oopa-S-S-TB</td> <td>giant/prodimages/12.jpg</td> </tr> <tr style="height:12.75pt" height="17"> <td style="height:12.75pt" height="17">Oopa-S-S-CR</td> <td>giant/prodimages/13.jpg</td> </tr> <tr style="height:12.75pt" height="17"> <td style="height:12.75pt" height="17">Oopa-S-S-CR</td> <td>giant/prodimages/14.jpg</td> </tr> <tr style="height:12.75pt" height="17"> <td style="height:12.75pt" height="17">Oopa-S-P-OWBW</td> <td>giant/prodimages/18.jpg</td> </tr> <tr style="height:12.75pt" height="17"> <td style="height:12.75pt" height="17">Oopa-S-P-OWBW</td> <td>giant/prodimages/19.jpg</td> </tr> <tr style="height:12.75pt" height="17"> <td style="height:12.75pt" height="17">Oopa-S-C-G</td> <td>giant/prodimages/20.jpg</td> </tr> <tr style="height:12.75pt" height="17"> <td style="height:12.75pt" height="17">Oopa-S-C-G</td> <td>giant/prodimages/21.jpg</td> </tr> </tbody></table>

 

[MickG]

I've just copied your data to new sheet and run the code with a commandButton and a basic module and Both work.
Have you got any "Merged cells", when I create one in column "A" I get your Error. !!!!

 

[philmatth]

Hi Mick,
This is annoying - especially for you and I do really appreciate your time. If I remove lines 24 onwards to 934 it works so there's obviously a problem with the data but I can't see it. I've copied over the two columns to a new file just in case but no joy.

The prod-id's are all the same format, there's nothing unusual in there. If you download the whole file from here http://www.autobitz.co.uk/test/book1.zip you'll see what I mean

 

[MickG]

Try this:-
There was a problem with non concurrent duplicates.

[COLOR=navy]Sub[/COLOR] MG26Sep41
'[COLOR=green][B]Forum Copy[/B][/COLOR]
[COLOR=navy]Dim[/COLOR] Rng     [COLOR=navy]As[/COLOR] Range
[COLOR=navy]Dim[/COLOR] Rw      [COLOR=navy]As[/COLOR] Range
[COLOR=navy]Dim[/COLOR] n       [COLOR=navy]As[/COLOR] [COLOR=navy]Integer[/COLOR]
[COLOR=navy]Dim[/COLOR] Dn      [COLOR=navy]As[/COLOR] Range
[COLOR=navy]Dim[/COLOR] DelRng  [COLOR=navy]As[/COLOR] Range
[COLOR=navy]Dim[/COLOR] k
[COLOR=navy]Dim[/COLOR] nRng    [COLOR=navy]As[/COLOR] Range
[COLOR=navy]Dim[/COLOR] Temp    [COLOR=navy]As[/COLOR] Range
[COLOR=navy]Dim[/COLOR] Ksz     [COLOR=navy]As[/COLOR] [COLOR=navy]Integer[/COLOR]
[COLOR=navy]Set[/COLOR] Rng = Range(Range("A1"), Range("A" & Rows.Count).End(xlUp))
    [COLOR=navy]With[/COLOR] CreateObject("scripting.dictionary")
        .CompareMode = vbTextCompare
[COLOR=navy]For[/COLOR] [COLOR=navy]Each[/COLOR] Dn [COLOR=navy]In[/COLOR] Rng
    [COLOR=navy]If[/COLOR] Not .Exists(Dn.Value) [COLOR=navy]Then[/COLOR]
        .Add Dn.Value, Dn
    [COLOR=navy]Else[/COLOR]
        [COLOR=navy]Set[/COLOR] .Item(Dn.Value) = Union(.Item(Dn.Value), Dn)
    [COLOR=navy]End[/COLOR] If
[COLOR=navy]Next[/COLOR]
[COLOR=navy]For[/COLOR] [COLOR=navy]Each[/COLOR] k [COLOR=navy]In[/COLOR] .Keys
    Ksz = IIf(.Item(k).Areas(1).Count = 1, 0, 1)
    [COLOR=navy]If[/COLOR] .Item(k).Count > 1 [COLOR=navy]Then[/COLOR]
        [COLOR=navy]For[/COLOR] n = 1 To .Item(k).Areas.Count
            [COLOR=navy]If[/COLOR] nRng [COLOR=navy]Is[/COLOR] Nothing [COLOR=navy]Then[/COLOR]
                [COLOR=navy]Set[/COLOR] nRng = .Item(k).Areas(n).Offset(1).Resize(.Item(k).Areas(n).Count - Ksz)
            [COLOR=navy]Else[/COLOR]
                [COLOR=navy]Set[/COLOR] nRng = Union(nRng, .Item(k).Areas(n))
            [COLOR=navy]End[/COLOR] If
[COLOR=navy]Next[/COLOR] n
[COLOR=navy]Set[/COLOR] Temp = .Item(k)(1).Offset(, 1)
    [COLOR=navy]For[/COLOR] [COLOR=navy]Each[/COLOR] Rw [COLOR=navy]In[/COLOR] .Item(k).Offset(, 1)
        Temp = Rw
        [COLOR=navy]Set[/COLOR] Temp = Temp.Offset(, 1)
    [COLOR=navy]Next[/COLOR] Rw
[COLOR=navy]   [/COLOR]
[COLOR=navy]    If[/COLOR] DelRng [COLOR=navy]Is[/COLOR] Nothing [COLOR=navy]Then[/COLOR]
         [COLOR=navy]Set[/COLOR] DelRng = nRng
[COLOR=navy]    Else[/COLOR]
         [COLOR=navy]Set[/COLOR] DelRng = Union(DelRng, nRng)
[COLOR=navy]    End[/COLOR] If
[COLOR=navy]Set[/COLOR] nRng = Nothing
[COLOR=navy]End[/COLOR] If
[COLOR=navy]Next[/COLOR] k
[COLOR=navy]     If[/COLOR] Not DelRng [COLOR=navy]Is[/COLOR] Nothing [COLOR=navy]Then[/COLOR] DelRng.EntireRow.Delete
[COLOR=navy]End[/COLOR] With
MsgBox "Run"
[COLOR=navy]End[/COLOR] [COLOR=navy]Sub[/COLOR]

Regards Mick