Old script not fully working

Mario0102

New Member
Joined
Mar 12, 2019
Messages
2
Hi All
A while ago I used a forum and posted a problem which was solved by using a VBA script. This script works most of the time but not always. The original problem I had was that I get given an excel sheet with 3 columns detailing a description, a part number and a location. I needed duplicate description and part number lines to combine the location and add a quantity column.

Example original:
Description Part Number Location
ABC 123 C1
DEF 456 C2
ABC 123 C3
DEF 456 C4

Example output:
Description Part Number Location Qty
ABC 123 C1, C3 2
DEF 456 C2, C4 2

Below is the script I have been given. If you run the script not all of the data comes across (about 10% is missing from the output). The original list can have up to 1000 lines. I have been looking at the code for hours now and have to admit it is beyond me to fully understand. Can any smarties out here help? Thank you so much in advance for any help.

Mario :)


Dim a, i As Long, j As Long, n As Long, z
ReDim z(1 To 2)
With Sheets("Sheet5").Range("a1").CurrentRegion
a = .Value
End With
With CreateObject("Scripting.Dictionary")
.comparemode = 1
For i = 1 To UBound(a, 1)
If Not .exists(a(i, 2)) Then
n = n + 1
z(1) = n
Set z(2) = CreateObject("Scripting.Dictionary")
z(2).comparemode = 1
z(2)(a(i, 1)) = Empty
For j = 1 To UBound(a, 2)
a(n, j) = a(i, j)
Next
.Item(a(i, 2)) = z
Else
z = .Item(a(i, 2))
If z(2).exists(a(i, 1)) Then
a(z(1), 3) = Join$(Array(a(z(1), 3), a(i, 3)), ", ")
z(2)(a(i, 1)) = Empty
.Item(a(i, 2)) = z
End If
End If
Next
End With

With Sheets.Add
.Range("A1").Resize(n, UBound(a, 2)).Value = a
.Columns.AutoFit
.Activate
End With
 

Excel Facts

Fastest way to copy a worksheet?
Hold down the Ctrl key while dragging tab for Sheet1 to the right. Excel will make a copy of the worksheet.

Special-K99

Well-known Member
Joined
Nov 7, 2006
Messages
8,425
Office Version
  1. 2019
Are you able to sort the original data by Description so all the ABC's come together and all the DEF's?
 

MickG

MrExcel MVP
Joined
Jan 9, 2008
Messages
14,841
Try this:-
Data on sheet 5 , Results sheet2.
Code:
[COLOR="Navy"]Sub[/COLOR] MG12Mar04
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Txt [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Sp [COLOR="Navy"]As[/COLOR] Variant, Sp2 [COLOR="Navy"]As[/COLOR] Variant
ray = Sheets("Sheet5").Range("A1").CurrentRegion.Resize(, 3)

[COLOR="Navy"]With[/COLOR] CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare

[COLOR="Navy"]For[/COLOR] n = 2 To UBound(ray, 1)
    Txt = ray(n, 1) & "," & ray(n, 2)
     [COLOR="Navy"]If[/COLOR] Not .Exists(Txt) [COLOR="Navy"]Then[/COLOR]
        .Add Txt, n
    [COLOR="Navy"]Else[/COLOR]
        .Item(Txt) = .Item(Txt) & "," & n
    [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR]

ReDim nray(1 To .Count + 1, 1 To UBound(ray, 2) + 1)
nray(1, 1) = "Description": nray(1, 2) = "Part Number"
nray(1, 3) = "Location": nray(1, 4) = "Qty"
c = 1

[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] k [COLOR="Navy"]In[/COLOR] .keys
    c = c + 1
       Sp = Split(k, ",")
         nray(c, 1) = Sp(0): nray(c, 2) = Sp(1)
           Sp2 = Split(.Item(k), ",")
            [COLOR="Navy"]For[/COLOR] n = 0 To UBound(Sp2)
                nray(c, 3) = nray(c, 3) & IIf(nray(c, 3) = _
                "", ray(Sp2(n), 3), "," & ray(Sp2(n), 3))
            [COLOR="Navy"]Next[/COLOR] n
            nray(c, 4) = UBound(Sp2) + 1
[COLOR="Navy"]Next[/COLOR] k
[COLOR="Navy"]With[/COLOR] Sheets("Sheet2").Range("A1").Resize(c, 4)
    .Value = nray
    .Borders.Weight = 2
    .Columns.AutoFit
    .HorizontalAlignment = xlCenter
[COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]End[/COLOR] With

[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]
Regards Mick
 
Last edited:
Master Excel Bundle

Excel contains over 450 functions, with more added every year. That’s a huge number, so where should you start? Right here with this bundle.

Forum statistics

Threads
1,167,826
Messages
5,855,875
Members
431,771
Latest member
CoryMelth

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top