Add 1 more column to Code

dantb

Active Member
Joined
Mar 20, 2002
Messages
358
Hello all: The below code combines duplicates, it Looks in Column A (Item Number), combines Column B (Quantities) and puts it on sheet2. My Question is can this be modified to add Column C (Description) data on sheet2 also? Thanks Dan

Sub test()
Dim dic As Object, x, y
Dim r As Range
Set dic = CreateObject("Scripting.Dictionary")
For Each r In Range("A1", Range("A65536").End(xlUp))
If Not IsEmpty(r) Then
If Not dic.exists(r.Value) Then
dic.Add r.Value, r.Offset(, 1).Value
Else
dic(r.Value) = dic(r.Value) + r.Offset(, 1).Value
End If
End If
Next
x = dic.keys: y = dic.items
If dic.Count < 1 Then Exit Sub
With Sheets("sheet2").Range("a1")
.Resize(UBound(x) + 1).Value = Application.Transpose(x)
.Offset(, 1).Resize(UBound(y) + 1).Value = _
Application.Transpose(y)
End With
End Sub
 

Excel Facts

Format cells as currency
Select range and press Ctrl+Shift+4 to format cells as currency. (Shift 4 is the $ sign).
try
Code:
Sub testx()
Dim dic As Object, w(), x
Dim r As Range
Set dic = CreateObject("Scripting.Dictionary")
For Each r In Range("A1", Range("A65536").End(xlUp))
    If Not IsEmpty(r) Then
        If Not dic.exists(r.Value) Then
            ReDim w(2)
            For i = 0 To 2: w(i) = r.Offset(, i).Value: Next
            dic.Add r.Value, r.Offset(, 1).Value
        Else
            w = dic(r.Value)
            For i = 1 To 2: w(i) = w(i) + r.Offset(, i).Value: Next
            dic(r.Value) = w
        End If
    End If
Next
x = dic.items
If dic.Count < 1 Then Exit Sub
With Sheets("sheet2").Range("a1")
    For i = LBound(x) To UBound(x)
        .Offset(i).Resize(, UBound(x(i)) + 1) = x(i)
    Next
End With
Set dic = Nothing: Erase x
End Sub
 
Upvote 0
Thanks jindon: I have been trying to get it to run but it is hanging on:

Else
w = dic(r.Value)


Any help would be appreciated thanks Dan
 
Upvote 0
Thanks Jindon: That got me past that line but now hangs on the (Next) in the below line, I Have no idea what to change, Thanks again Dan

For i = 1 To 2: w(i) = w(i) + r.Offset(, i).Value: Next
 
Upvote 0
can you watch the variables in the Local Window?
1) open VB editor
2) go to View -> Local Window then run the following code
3) when it poses, you can see the variables in the local window
4) as you hit F8, the code will execute line by line
5) watch the movement of variable w, you can see the element, if you click on + sign
Code:
Sub testx() 
Dim dic As Object, w, x 
Dim r As Range 
Set dic = CreateObject("Scripting.Dictionary") 
For Each r In Range("A1", Range("A65536").End(xlUp)) 
    If Not IsEmpty(r) Then 
        If Not dic.exists(r.Value) Then 
            ReDim w(2) 
            For i = 0 To 2: w(i) = r.Offset(, i).Value: Next 
            dic.Add r.Value, r.Offset(, 1).Value 
        Else 
Stop
            w = dic(r.Value) 
            For i = 1 To 2: w(i) = w(i) + r.Offset(, i).Value: Next 
            dic(r.Value) = w 
        End If 
    End If 
Next 
x = dic.items 
If dic.Count < 1 Then Exit Sub 
With Sheets("sheet2").Range("a1") 
    For i = LBound(x) To UBound(x) 
        .Offset(i).Resize(, UBound(x(i)) + 1) = x(i) 
    Next 
End With 
Set dic = Nothing: Erase x 
End Sub
 
Upvote 0
Thanks Jindon really useful information, I didn’t know the editor had that feature. I see all the variables and will try to see why it is hanging. Thanks again Dan
 
Upvote 0

Forum statistics

Threads
1,216,380
Messages
6,130,291
Members
449,570
Latest member
TomMacca52

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
Back
Top