Modified code sum repeat data [Solved]

Report
Posts
69
Registration date
Thursday July 18, 2019
Status
Member
Last seen
January 15, 2021
-
Posts
69
Registration date
Thursday July 18, 2019
Status
Member
Last seen
January 15, 2021
-
hello
actually i search code to sum repeat values and i have about 2000 rows so that's why i do that by code instead of formula the result not right
the image 1 is the right result in col d,e
the image 2 is wrong what i got after run code



and this my code
Option Explicit

Sub Main()

CollectArray "A", "D"

DoSum "D", "E", "A", "B"

End Sub


' collect array from a specific column and print it to a new one without duplicates
' params:
' fromColumn - this is the column you need to remove duplicates from
' toColumn - this will reprint the array without the duplicates
Sub CollectArray(fromColumn As String, toColumn As String)

ReDim arr(1) As String

Dim i As Long
For i = 2 To Range(fromColumn & Rows.Count).End(xlUp).Row
arr(UBound(arr)) = Range(fromColumn & i)
ReDim Preserve arr(UBound(arr) + 1)
Next i
ReDim Preserve arr(UBound(arr) - 1)
RemoveDuplicate arr
Range(toColumn & "1:" & toColumn & Range(toColumn & Rows.Count).End(xlUp).Row).ClearContents
For i = LBound(arr) To UBound(arr)
Range(toColumn & i + 1) = arr(i)
Next i
End Sub


'' params:
' fromColumn - this is the column with string to match against
' toColumn - this is where the SUM will be printed to
' originalColumn - this is the original column including duplicate
' valueColumn - this is the column with the values to sum
Private Sub DoSum(fromColumn As String, toColumn As String, originalColumn As String, valueColumn As String)
Range(toColumn & "1:" & toColumn & Range(toColumn & Rows.Count).End(xlUp).Row).ClearContents
Dim i As Long
For i = 2 To Range(fromColumn & Rows.Count).End(xlUp).Row
Range(toColumn & i) = WorksheetFunction.SumIf(Range(originalColumn & ":" & originalColumn), Range(fromColumn & i), Range(valueColumn & ":" & valueColumn))
Next i
End Sub


Private Sub RemoveDuplicate(ByRef StringArray() As String)
Dim lowBound$, UpBound&, A&, B&, cur&, tempArray() As String
If (Not StringArray) = True Then Exit Sub
lowBound = LBound(StringArray): UpBound = UBound(StringArray)
ReDim tempArray(lowBound To UpBound)
cur = lowBound: tempArray(cur) = StringArray(lowBound)
For A = lowBound + 1 To UpBound
For B = lowBound To cur
If LenB(tempArray(B)) = LenB(StringArray(A)) Then
If InStrB(1, StringArray(A), tempArray(B), vbBinaryCompare) = 1 Then Exit For
End If
Next B
If B > cur Then cur = B
tempArray(cur) = StringArray(A)
Next A
ReDim Preserve tempArray(lowBound To cur): StringArray = tempArray
End Sub

thanks advance

3 replies

Posts
2774
Registration date
Sunday September 12, 2010
Status
Moderator
Last seen
July 13, 2021
465
Hi Abdel,

Why would a formula produce an incorrect result? Have you tried this one:
=SUMIF(A:A,D2,B:B)

Best regards,
Trowa
Posts
69
Registration date
Thursday July 18, 2019
Status
Member
Last seen
January 15, 2021

hi, Trowa sorry about delaying my answer about the formula i know it but i have ever told you contain a huge data that's why i would do that by code it takes more time to pull the formula down about 2000 rows if can you fix my code or alternative to do that i truly appreciate that
thanks again
Posts
2774
Registration date
Sunday September 12, 2010
Status
Moderator
Last seen
July 13, 2021
465
Hi Abdel,

Your code looks overly complicated, so I decided to write my own. Here is my take on getting the requested task done:
Sub RunMe()
Dim mFind As Range

Columns("A:A").Copy Columns("D:D")
Columns("D:D").RemoveDuplicates Columns:=1, Header:=xlYes

For Each cell In Range("D2:D" & Range("D1").End(xlDown).Row)
    Set mFind = Columns("A:A").Find(what:=cell.Value, lookat:=xlWhole)
    fAddress = mFind.Address
    Do
        cell.Offset(0, 1).Value = cell.Offset(0, 1).Value + mFind.Offset(0, 1).Value
        Set mFind = Columns("A:A").FindNext(mFind)
    Loop While mFind.Address <> fAddress
Next cell
End Sub


Best regards,
Trowa
Posts
69
Registration date
Thursday July 18, 2019
Status
Member
Last seen
January 15, 2021

thanks Trowa but your code doesn't work well it sums values repeatedly each item it continues summing every time run the macro it supposing summing one if i time even run macro repeatedly
Posts
2774
Registration date
Sunday September 12, 2010
Status
Moderator
Last seen
July 13, 2021
465
Hi Abdel,

When you want to run the code multiple times, then you can clear the results first:
Range("D2:E" & Range("E1").End(xlDown).Row).ClearContents


Or use the slightly adjusted code below:
Sub RunMe()
Dim mCount As Long
Dim mFind As Range

Columns("A:A").Copy Columns("D:D")
Columns("D:D").RemoveDuplicates Columns:=1, Header:=xlYes

For Each cell In Range("D2:D" & Range("D1").End(xlDown).Row)
    Set mFind = Columns("A:A").Find(what:=cell.Value, lookat:=xlWhole)
    fAddress = mFind.Address
    Do
        mCount = mCount + mFind.Offset(0, 1).Value
        Set mFind = Columns("A:A").FindNext(mFind)
    Loop While mFind.Address <> fAddress
    cell.Offset(0, 1).Value = mCount
    mCount = 0
Next cell
End Sub


The choice is yours.

Best regards,
Trowa
Posts
69
Registration date
Thursday July 18, 2019
Status
Member
Last seen
January 15, 2021

many thanks ! Trowa it's perfect

Subscribe To Our Newsletter!

The Best of CCM in Your Inbox

Subscribe To Our Newsletter!