VBA, Arrais and Dict: combine duplicate rows and sum the values

[Nelson78]

Hello everybody.

I have a table in the following range:

Worksheets(1).Range("A2:R" & lr2 + lr3 - 3)

Having column A as a reference point (it is a list of cities), if the same city is repeated, I've to sum all the value in column in order to produce only a row for any city.

Then overwrite the table.


Anyway, at the moment I've figured out only to sum the column B.

Set Rng = Worksheets(1).Range("A2:R" & lr2 + lr3 - 3)

Set Dic = CreateObject("Scripting.Dictionary")
arr = Rng.Value

For i = 1 To UBound(arr, 1)
    Dic(arr(i, 1)) = Dic(arr(i, 1)) + arr(i, 2)
Next

Application.ScreenUpdating = False

Rng.ClearContents

Rng.Range("A1").Resize(Dic.Count, 1) = Application.WorksheetFunction.Transpose(Dic.keys)
Rng.Range("B1").Resize(Dic.Count, 1) = Application.WorksheetFunction.Transpose(Dic.items)

Application.ScreenUpdating = True

How can I expand the same process to all columns until R?

Thank's in advance.

 

[Fluff]

How about

Sub Nelson78()
   Dim Ary As Variant, Tmp As Variant, Cols As Variant
   Dim r As Long, c As Long
   
   With Worksheets(1).Range("A2:R" & lr2 + lr3 - 3)
      Ary = .Value2
      .ClearContents
   End With
   ReDim Cols(1 To UBound(Ary, 2) - 1)
   For c = 2 To UBound(Ary, 2)
      Cols(c - 1) = c
   Next c
   With CreateObject("scripting.dictionary")
      For r = 2 To UBound(Ary)
         If Not .Exists(Ary(r, 1)) Then
            .Add Ary(r, 1), Application.Index(Ary, r, Array(Cols))
         Else
            Tmp = .Item(Ary(r, 1))
            For c = 2 To UBound(Ary, 2)
               Tmp(c - 1) = Tmp(c - 1) + Ary(r, c)
            Next c
            .Item(Ary(r, 1)) = Tmp
         End If
      Next r
      Range("A1").Resize(.Count).Value = Application.Transpose(.Keys)
      Range("B1").Resize(.Count, 3).Value = Application.Index(.Items, 0, 0)
   End With
End Sub

 

[Nelson78]

How about

Sub Nelson78()
   Dim Ary As Variant, Tmp As Variant, Cols As Variant
   Dim r As Long, c As Long
   
   With Worksheets(1).Range("A2:R" & lr2 + lr3 - 3)
      Ary = .Value2
      .ClearContents
   End With
   ReDim Cols(1 To UBound(Ary, 2) - 1)
   For c = 2 To UBound(Ary, 2)
      Cols(c - 1) = c
   Next c
   With CreateObject("scripting.dictionary")
      For r = 2 To UBound(Ary)
         If Not .Exists(Ary(r, 1)) Then
            .Add Ary(r, 1), Application.Index(Ary, r, Array(Cols))
         Else
            Tmp = .Item(Ary(r, 1))
            For c = 2 To UBound(Ary, 2)
               Tmp(c - 1) = Tmp(c - 1) + Ary(r, c)
            Next c
            .Item(Ary(r, 1)) = Tmp
         End If
      Next r
      Range("A1").Resize(.Count).Value = Application.Transpose(.Keys)
      Range("B1").Resize(.Count, 3).Value = Application.Index(.Items, 0, 0)
   End With
End Sub

Two problems:

1) I need to calculate sums until column R (after running the macro, I see it calculates until C);
2) it overwrites the header.

Thank's.

 

[Nelson78]

Two problems:

1) I need to calculate sums until column R (after running the macro, I see it calculates until C);
2) it overwrites the header.

Thank's.

Point 1 could be fixed with:

Range("B1").Resize(.Count, [COLOR="#FF0000"]17[/COLOR]).Value = Application.Index(.Items, 0, 0)

instead of

Range("B1").Resize(.Count, 3).Value = Application.Index(.Items, 0, 0)

 

[Fluff]

How about

      Range("A2").Resize(.Count).Value = Application.Transpose(.Keys)
      Range("B2").Resize(.Count, UBound(Ary, 2) - 1).Value = Application.Index(.Items, 0, 0)

 

[Nelson78]

How about

      Range("A2").Resize(.Count).Value = Application.Transpose(.Keys)
      Range("B2").Resize(.Count, UBound(Ary, 2) - 1).Value = Application.Index(.Items, 0, 0)

Now the header is ok, but the first city of the list is missing.

 

[Fluff]

How about

Sub Nelson78()
   Dim Ary As Variant, Tmp As Variant, Cols As Variant
   Dim r As Long, c As Long
   
   With Sheets(1).Range("A2:R" & lr2 + lr3 - 3)
      Ary = .Value2
      .ClearContents
   End With
   ReDim Cols(1 To UBound(Ary, 2) - 1)
   For c = 2 To UBound(Ary, 2)
      Cols(c - 1) = c
   Next c
   With CreateObject("scripting.dictionary")
      For r = 1 To UBound(Ary)
         If Not .Exists(Ary(r, 1)) Then
            .Add Ary(r, 1), Application.Index(Ary, r, Array(Cols))
         Else
            Tmp = .Item(Ary(r, 1))
            For c = 2 To UBound(Ary, 2)
               Tmp(c - 1) = Tmp(c - 1) + Ary(r, c)
            Next c
            .Item(Ary(r, 1)) = Tmp
         End If
      Next r
      Range("A2").Resize(.Count).Value = Application.Transpose(.Keys)
      Range("B2").Resize(.Count, UBound(Ary, 2) - 1).Value = Application.Index(.Items, 0, 0)
   End With
End Sub

 

[Nelson78]

How about

Sub Nelson78()
   Dim Ary As Variant, Tmp As Variant, Cols As Variant
   Dim r As Long, c As Long
   
   With Sheets(1).Range("A2:R" & lr2 + lr3 - 3)
      Ary = .Value2
      .ClearContents
   End With
   ReDim Cols(1 To UBound(Ary, 2) - 1)
   For c = 2 To UBound(Ary, 2)
      Cols(c - 1) = c
   Next c
   With CreateObject("scripting.dictionary")
      For r = 1 To UBound(Ary)
         If Not .Exists(Ary(r, 1)) Then
            .Add Ary(r, 1), Application.Index(Ary, r, Array(Cols))
         Else
            Tmp = .Item(Ary(r, 1))
            For c = 2 To UBound(Ary, 2)
               Tmp(c - 1) = Tmp(c - 1) + Ary(r, c)
            Next c
            .Item(Ary(r, 1)) = Tmp
         End If
      Next r
      Range("A2").Resize(.Count).Value = Application.Transpose(.Keys)
      Range("B2").Resize(.Count, UBound(Ary, 2) - 1).Value = Application.Index(.Items, 0, 0)
   End With
End Sub

Yes, the tests I've executed so far are ok.

Thank's.

 

[Fluff]

You're welcome & thanks for the feedback