# Old script not fully working

#### Mario0102

##### New Member
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

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

### Excel Facts

Is there a shortcut key for strikethrough?
Ctrl+S is used for Save. Ctrl+5 is used for Strikethrough. Why Ctrl+5? When you use hashmarks to count |||| is 4, strike through to mean 5.

#### Special-K99

##### Well-known Member
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
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]
[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:
• Mario0102

#### Mario0102

##### New Member
Hi Mick
That is absolutely fantastic, thank you so much. You're welcome

Replies
4
Views
47
Replies
6
Views
87
Replies
6
Views
92
Replies
13
Views
241
Replies
6
Views
87