Combining multiple rows into a single row.

[Detectiveclem]

Hi, I have a spreadsheet which has circa 23,000 rows of data.


Column ‘A’ has the client ID, this being a unique number for each client. However there are multi entries for the same client. In column J has a monetary amount.


What I would like to achieve is to merge all the same relating to the same client on a single row and provide a total monetary figure in column J (total of all entries relating to that client). The spreadsheet uses Column A:R, with the data relating to that client being identical with the except of Column J which I’ve mentioned.


Help with this would be greatly appreciated

 

[Fluff]

Do you have any formulae or formatting on the sheet?

 

[Detectiveclem]

Hi Fluff,

No formulas or formatting

 

[Fluff]

Ok, how about

Sub Detectiveclem()
   Dim Ary As Variant, Nary As Variant
   Dim r As Long, c As Long, nr As Long
   
   Ary = Sheets("Sheet1").Range("A1").CurrentRegion.Value2
   ReDim Nary(1 To UBound(Ary), 1 To UBound(Ary, 2))
   With CreateObject("scripting.dictionary")
      For r = 1 To UBound(Ary)
         If Not .exists(Ary(r, 1)) Then
            nr = nr + 1
            .Add Ary(r, 1), nr
            For c = 1 To UBound(Ary, 2)
               Nary(nr, c) = Ary(r, c)
            Next c
         Else
            Nary(.Item(Ary(r, 1)), 10) = Nary(.Item(Ary(r, 1)), 10) + Ary(r, 10)
         End If
      Next r
   End With
   Sheets("Sheet2").Range("A1").Resize(nr, UBound(Ary, 2)).Value = Nary
End Sub

This currently outputs the data on Sheet2, just to check it works. It can easily be changed to clear sheet1 & then put the data back in.

 

[Detectiveclem]

Hi Fluuf,

Tried this and altered the sheet name to the correct name, but the debugger stopped at the final line Sheets("Sheet2").Range("A1").Resize(nr, UBound(Ary, 2)).Value = Nary

 

[Detectiveclem]

This is the full code,

Sub Rowmerge()
Dim Ary As Variant, Nary As Variant
Dim r As Long, c As Long, nr As Long

Ary = Sheets("PSCmerge").Range("A1").CurrentRegion.Value2
ReDim Nary(1 To UBound(Ary), 1 To UBound(Ary, 2))
With CreateObject("scripting.dictionary")
For r = 1 To UBound(Ary)
If Not .exists(Ary(r, 1)) Then
nr = nr + 1
.Add Ary(r, 1), nr
For c = 1 To UBound(Ary, 2)
Nary(nr, c) = Ary(r, c)
Next c
Else
Nary(.Item(Ary(r, 1)), 10) = Nary(.Item(Ary(r, 1)), 10) + Ary(r, 10)
End If
Next r
End With
Sheets("Sheet2").Range("A1").Resize(nr, UBound(Ary, 2)).Value = Nary
End Sub

 

[Detectiveclem]

Row 1 contains headers, does this impact on the code?

 

[Fluff]

Do you have a sheet called sheet2?

 

[Detectiveclem]

No just Sheet1 and other named sheets. Do I have to create a sheet2?

 

[Fluff]

It would be better, that way you can check that everything has worked, without destroying your data.