Getting Unique Ids and from a column and adding corresponding cells

[geomic788]

Hello!
Thank you for this amazing Forum!
Im having some sort of trouble in excel
Here's the situation

I ve got a really long column (3000 entries) with product codes and corresponding quantities.Since each product can be found in different locations there are multiple entries of the same product code.So i need a way to sum up all the quantities in a different sheet next to a list

1st Table

PrdCode Quantity Location
4001 2 5
4001 5 2
4001s 11 15
17403s 3 5
17403s 1 8
4001 2 1
4001s 12 12

Desired Result in different sheet
PrdCode Quantity Locations
4001 9 5,2,1
4001s 23 12,15
17403s 4 5,8


I know the Locations with commas is a bit too much to ask and mabye really complicated.The first part would be awesome as well.Just sums per product code would be great.

Thank you!!!!

 

[MikeDBMan]

Try this:

Sub Doit()
Dim X, Y As Long
Dim DataArray(50000, 3) As Variant
Dim Fnd As Long
Dim Found As Integer
'start on the sheet with the table, I am assuming is Sheet2.
Sheets("Sheet2").Select  'adjust name of sheet with table as necessary
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Application.EnableEvents = False
'Application.DisplayAlerts=False  'may not always want to turn this one to false!
Application.Cursor = xlWait
With Application
    .Calculation = xlManual
    .MaxChange = 0.001
End With
X = 2 ' I am assuming the data starts on row 2
Do While True
    If Cells(X, 1).Value = Empty Then Exit Do  'assuming if cells in column A is empty then we're done.
    Let Found = 0
    For Y = 1 To Fnd
        If Cells(X, 1).Value = DataArray(Y, 1) Then
            Found = 1
            Let DataArray(Y, 2) = DataArray(Y, 2) + Cells(X, 2).Value 'add the new quantity
            Let DataArray(Y, 3) = DataArray(Y, 3) & ", " & Cells(X, 3).Value
            Exit For
        End If
    Next
    If Found = 0 Then
        Fnd = Fnd + 1
        For Y = 1 To 3
            Let DataArray(Fnd, Y) = Cells(X, Y).Value
        Next
    End If
    X = X + 1
Loop
'now when done, go to the sheet to put the summary.  I will add it here
Dim NewWKs As Worksheet
Set NewWKs = Worksheets.Add
NewWKs.Name = "Summary"
Cells(1, 1).Value = "Product Code"
Cells(1, 2).Value = "Quantity"
Cells(1, 3).Value = "Locations Found"
For X = 2 To Fnd + 1
    For Y = 1 To 3
        Cells(X, Y).Value = DataArray(X - 1, Y)
    Next
Next
Cells.Select
Cells.EntireColumn.AutoFit
Range("A2").Select
ActiveWindow.FreezePanes = True
    Columns("A:A").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
 
Range("A2").Select
Beep
Beep
 
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Cursor = xlDefault
'Application.DisplayAlerts=True
With Application
    .Calculation = xlAutomatic
    .MaxChange = 0.001
End With
 
End Sub

 

[JoeMo]

Welcome to the Forum. This will add a sheet named "Summary" where your data will be summarized. The code should be run with your data sheet as the active sheet.

Sub Geomic()
'Run from the data sheet
Dim lRs As Long, lRr As Long, Qty As Long, Loc As String, sSht _
    As Worksheet, rSht As Worksheet, c As Range, vA As Variant
    
Set sSht = ActiveSheet
Application.ScreenUpdating = False
Application.DisplayAlerts = False
On Error Resume Next
Sheets("Summary").Delete
On Error GoTo 0
Application.DisplayAlerts = True
Set rSht = Sheets.Add(after:=sSht)
rSht.Name = "Summary"
rSht.Range("B1:C1").Value = Array("Quantity", "Location")
sSht.Select
lRs = Range("A" & Rows.Count).End(xlUp).Row
Range("A1", "A" & lRs).AdvancedFilter Action:=xlFilterCopy, copytorange:=rSht.Range("A1"), unique:=True
lRr = rSht.Range("A" & Rows.Count).End(xlUp).Row
vA = sSht.Range("A2", "C" & lRs)
For Each c In rSht.Range("A2", "A" & lRr)
    Qty = 0
    Loc = ""
    For i = LBound(vA, 1) To UBound(vA, 1)
        If vA(i, 1) = c.Value Then
            Qty = Qty + vA(i, 2)
            Loc = Loc & "," & vA(i, 3)
        End If
    Next i
    c.Offset(0, 1) = Qty
    c.Offset(0, 2) = Right(Loc, Len(Loc) - 1)
Next c
rSht.Columns("A:C").AutoFit
End Sub

 

[geomic788]

Thank you very much for your quick replys.I mean u guyes are awesome!I will try to intergrate it on my main project tomorow morning when i get at the office.Right now i checked it on a draft project and it works.Thank you very much!

 

[geomic788]

Joe Mo i thought of something extra that could cause problems when intergating to the main project.I am a complete VBA noob so some help would be great.
My actual columns are

A:Product Code B:Only numbers from column A( for right sorting) C: Quantity DStuff already taken off the location.this is useless for our macro) E:Location

Please be so kind to modify the function u made in order to work with the specific columns

Thank u very very much!

 

[JoeMo]

Joe Mo i thought of something extra that could cause problems when intergating to the main project.I am a complete VBA noob so some help would be great.
My actual columns are

A:Product Code B:Only numbers from column A( for right sorting) C: Quantity DStuff already taken off the location.this is useless for our macro) E:Location

Please be so kind to modify the function u made in order to work with the specific columns

Thank u very very much!

So for the input data you care only about columns A, C and E, is that right? Are the column headers in row 1 of the input sheet? And, do you still want only PrdCode, Qty and Locations on the summary sheet in columns A-C)?

 

[geomic788]

So for the input data you care only about columns A, C and E, is that right? Are the column headers in row 1 of the input sheet? And, do you still want only PrdCode, Qty and Locations on the summary sheet in columns A-C)?

Yes that is correct.Will the results be sortable?Or should i sort the data beforehand ?

 

[JoeMo]

Yes that is correct.Will the results be sortable?Or should i sort the data beforehand ?

The data do not need to be sorted. A sort of the summary data can be added to the code - what column(s) do you want to sort on. Ascending or descending?

 

[geomic788]

The data do not need to be sorted. A sort of the summary data can be added to the code - what column(s) do you want to sort on. Ascending or descending?

I am at the office now so i can see my main project and check everything.I made a mistake.
The columns that i am interested in are A D and F.The sorting part is kinda tricky cause we have multiple formats of product codes as in :
4001
4002
4001S
27425
27484S
4357s7

These should be sorted like this:
4001
4001S
4002
4357s7
27425
27484S

If you make the macro please make it separately so i can use it on my input data as well so i can avoid sorting it with the helper column which makes all the codes of the format 4357s7 i mean the ones that doesent end with a letter end up in the end.
Man thank you so much for doing all these for me

 

[JoeMo]

You can remove the sort at the end of this code if it doesn't sort in the order you want.

Sub Geomic()
'Run from the data sheet
Dim lRs As Long, lRr As Long, Qty As Long, Loc As String, sSht _
    As Worksheet, rSht As Worksheet, c As Range, vA As Variant
    
Set sSht = ActiveSheet
Application.ScreenUpdating = False
Application.DisplayAlerts = False
On Error Resume Next
Sheets("Summary").Delete
On Error GoTo 0
Application.DisplayAlerts = True
Set rSht = Sheets.Add(after:=sSht)
rSht.Name = "Summary"
rSht.Range("B1:C1").Value = Array("Quantity", "Location")
sSht.Select
lRs = Range("A" & Rows.Count).End(xlUp).Row
Range("A1", "A" & lRs).AdvancedFilter Action:=xlFilterCopy, copytorange:=rSht.Range("A1"), unique:=True
lRr = rSht.Range("A" & Rows.Count).End(xlUp).Row
vA = sSht.Range("A2", "F" & lRs)
For Each c In rSht.Range("A2", "A" & lRr)
    Qty = 0
    Loc = ""
    For i = LBound(vA, 1) To UBound(vA, 1)
        If vA(i, 1) = c.Value Then
            Qty = Qty + vA(i, 4)
            Loc = Loc & "," & vA(i, 6)
        End If
    Next i
    c.Offset(0, 1) = Qty
    c.Offset(0, 2) = Right(Loc, Len(Loc) - 1)
Next c
With rSht
    .Select
    .Columns("A:C").AutoFit
    .Range("A1").CurrentRegion.Sort key1:=Range("A1"), order1:=xlAscending, Header:=xlYes
End With
End Sub