CODEWITHSUNDEEP
vba
Marcel
Marcel

Reputation: 41

Consolidate several rows into a single row vba

I need to create a sub to consolidate some data. I have several rows (anywhere from 4k to 20k) that I need to consolidate and sum the values from each column (from C to N).

The input data looks like this:

input
input

For the output, it should sum the columns for each SKU (Column A) and delete the rest.

Like this:

output
output

It should be simple enough, but I can’t seem to come up with an appropriate solution. I tried using an array with a scripting dictionary but I can’t figure out how to store more than a single value for each key. Sample (unfinished) code:

Dim sArray As Variant
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")

sArray = Range(currentRange).Value

    For i = 1 To UBound(sArray, 1)
       For j = 3 To UBound(sArray, 2)
          If dict.exists(sArray(i, 1)) = False Then
             dict.Add sArray(i, 1), sArray(i, j)
      Else
     'this part is very wrong:
             dict(sArray(i, 1)) = dict(sArray(i, j)) + sArray(i, j)
          End If
       Next
Next

Thank you very much in advance!

Upvotes: 2

Views: 207

Answers (2)

Marcel
Marcel

Reputation: 41

I came up with the following solution instead and it took 30 seconds to run it (not entirely my own idea, borrowed some code from someplace else):

    Sub dupes()
    Dim MyRange As Range
    Dim RowNum As Long
    RowNum = 1

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    Set MyRange = Range("A2:N14200") 'for test only, on the real sub it's dynamic
    MyRange.Sort key1:=Range("A2"), order1:=xlAscending

    For Each Row In MyRange
        With Cells
            While Cells(RowNum, 1) = Cells(RowNum + 1, 1) And Cells(RowNum  + 1, 1) <> "" 'very important the second condition or it will continue to loop forever
                For i = 3 To 14
                    Cells(RowNum, i) = Cells(RowNum, i) + Cells(RowNum + 1, i)
                Next
                Rows(RowNum + 1).EntireRow.Delete
            Wend
        End With
        RowNum = RowNum + 1
    Next
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
    End Sub

It's kinda messy but it does the trick. Thanks to everyone!

Upvotes: 1

Scott Craner
Scott Craner

Reputation: 152660

Try this, It sums the values in Column Q:AB then paste them back and removes the duplicates.

Sub dupremove()
Dim ws As Worksheet
Dim lastrow As Long

Set ws = Sheets("Sheet12") ' Change to your sheet

With ws
    lastrow = .Range("A" & .Rows.Count).End(xlUp).Row
    With .Range("C2:N" & lastrow)
        .Offset(, 14).FormulaR1C1 = "=SUMIF(C1,RC1,C[-14])"
        .Value = .Offset(, 14).Value
        .Offset(, 14).ClearContents
    End With
    With .Range("A1:N" & lastrow)
        .Value = .Value
        .RemoveDuplicates 1, xlYes
    End With


End With

Before:

enter image description here

After:

enter image description here

Upvotes: 1

Related Questions