Selected Answer
Kalil
(Note that I've removed my earlier Answer and replaced it with one using an array solution for the speed needed for several thousands records).
The revised file attached has a new sheet "Sort many" with 2,000 records in columns A:D, column A is sorted randomly bi ID (apart from the first few records- used for test purposes*). There's a green shape "Do sort and sum" which is assigned to the macro below...
"SortSumValues" (code below, commented for your guidance) is in Module 1, together with a function ArrayRemoveDups to remove duplicates from an array.
Click the green shape "Do sort and sum" and the results will quickly appear in columns G:K. (On my old machine, it took less than one second to sort count 2,000 records with 1,001 unique values).
The right-most column K shows how many records matched the ID (the quantities are added in column J).
Here's the main code:
Option Base 1
Sub SortSumGroupedValues()
'Uses Option Base 1 for ease of handling arrays
'
Dim SortArray As Variant, SortArrayTemp As Variant, Temp As Variant
Dim m As Integer, n As Integer, p As Integer, q As Integer
Dim OutRng As Range
Const deLim = "||" ' combination of characters (hopefuly rare in cells) used to separate values,
Range("G:K").Clear ' remove previous results
' copy data into array
SortArrayTemp = Range("A2:D" & Range("A" & Rows.Count).End(xlUp).Row).Value
' pack three columns into first cell, using delimiter
For m = LBound(SortArrayTemp, 1) To UBound(SortArrayTemp, 1)
SortArrayTemp(m, 1) = SortArrayTemp(m, 1) & deLim & SortArrayTemp(m, 2) & deLim & SortArrayTemp(m, 3)
Next m
'call function to remove duplicates (via conversion to Collection)
SortArray = ArrayRemoveDups(SortArrayTemp) ' returns 1-D array
'bubble sort SortArray (= unique values from column 1)
For m = LBound(SortArray, 1) To (UBound(SortArray, 1) - 1)
For n = (m + 1) To UBound(SortArray, 1)
If SortArray(m) > SortArray(n) Then
Temp = SortArray(m)
SortArray(m) = SortArray(n)
SortArray(n) = Temp
Temp = ""
End If
Next n
Next m
'Expand SortArray to add a dimension (=make 4 columns for data + 1 for count)
ReDim Temp(UBound(SortArray), 5)
For m = LBound(SortArray) To UBound(SortArray)
Temp(m, 1) = SortArray(m)
Next m
SortArray = Temp
Temp = ""
' loop through data in temp array
For m = LBound(SortArrayTemp, 1) To UBound(SortArrayTemp, 1)
'loop through data key on sorted array
For n = LBound(SortArray, 1) To UBound(SortArray, 1) ' if data key found in sorted array
'check if data key matches sorted key
If SortArray(n, 1) = SortArrayTemp(m, 1) Then
SortArray(n, 4) = SortArray(n, 4) + SortArrayTemp(m, 4) ' add values
SortArray(n, 5) = SortArray(n, 5) + 1 'increase count
End If
Next n
Next m
' unpack first cell of each row to cells 3, 2 then 1 (removing delimiter)
For n = LBound(SortArray, 1) To UBound(SortArray, 1) '
m = Len(deLim)
p = InStr(SortArray(n, 1), deLim)
q = InStrRev(SortArray(n, 1), deLim)
SortArray(n, 3) = Right(SortArray(n, 1), Len(SortArray(n, 1)) - q - m + 1)
SortArray(n, 2) = Mid(SortArray(n, 1), p + m, Len(SortArray(n, 1)) - q - m + 1)
SortArray(n, 1) = Left(SortArray(n, 1), p - 1)
Next n
'copy headers
Range("G1:J1") = Range("A1:D1").Value 'copy headers
Range("k1") = "Records"
With Range("G1:K1")
.Font.Bold = True
.Interior.ColorIndex = 19
.Borders.LineStyle = xlContinuous
End With
' display sorted and summed array
Set OutRng = Range("G2").Resize(UBound(SortArray, 1), 5)
With OutRng
.Value = SortArray ' "paste" sorted array
.Interior.ColorIndex = 35
.Borders.LineStyle = xlContinuous
End With
Range("G:K").Columns.AutoFit
MsgBox "Success- pasted " & UBound(SortArray, 1) & " records in G:K, adding quantities when columns 1 to 3 all match"
End Sub
Note that the general declaration "
Option Base 1" MUST appear in the same module as this code (otherwise the array handling will mess up).
Revision 1: The code above (and attached file) is revised so that the records are summed only where columns 1 to 3 are the same (previously it assumed column A was unique and assumes B, C and D are the same for the same value of A). The parts in bold above show the key differences. Essentially I pack three columns into 1, using the pipe character | twice as a delimiter between the values. Once the sort and sum has been done on that combination, the macro then unpacks them). This may be frowned on programmatically but it works!)
* The first 7 records have the same data in column A (so I could test the search loops) but columns B and C differ. ID AA-12-0 will show three sepaarte records (where B and C differ) with a total count of 7. You can easily check the quantity of that too.
Hope this is what you need.