Combining Data based on a column without using Pivot?

[JumboCactuar]

Hi,
ive seen this done before with use of dictionary but unsure how:

With the following Data i want to combine rows based on Points like you would do with a pivot

Name	Age	Points
John	19	21
Fred	43	3
Tim	22	5
John	19	4
Alex	18	47
Fred	43	6
Tim	22	7
Luke	20	11
John	19	2

<tbody>
</tbody>

Output:

Name	Age	Sum of Points
Alex	18	47
Fred	43	9
John	19	27
Luke	20	11
Tim	22	12

<tbody>
</tbody>

Can it be done quickly with VBA if a lot of data? Also the amount of columns and Points column vary so can i set the column which i want to combine with

thanks

 

[sandy666]

with PowerQuery (Get&Transform)

Name	Age	Points		Name	Age	Sum
John	19​	21​		Alex	18​	47​
Fred	43​	3​		Fred	43​	9​
Tim	22​	5​		John	19​	27​
John	19​	4​		Luke	20​	11​
Alex	18​	47​		Tim	22​	12​
Fred	43​	6​
Tim	22​	7​
Luke	20​	11​
John	19​	2​

[SIZE=1]// Table1
let
    Source = Excel.CurrentWorkbook(){[Name="Table1"]}[Content],
    Type = Table.TransformColumnTypes(Source,{{"Name", type text}, {"Age", Int64.Type}, {"Points", Int64.Type}}),
    Group = Table.Group(Type, {"Name", "Age"}, {{"Sum", each List.Sum([Points]), type number}}),
    Sort = Table.Sort(Group,{{"Name", Order.Ascending}})
in
    Sort[/SIZE]

 

[JumboCactuar]

thanks @sandy666 but im looking for a VBA option

someone gave me this before which is very close to what i need, only i need to output entire table with sums

Sub Take_The_Cake()

    Dim rngAdd As Range
    Dim intSum As Integer
    Dim strAddress As String


    Set dicNew = CreateObject("scripting.dictionary")


    For Each cell In Range("a2:a" & Range("a2").End(xlDown).Row)
        dicNew(cell.Value) = 1
    Next cell


    PointsOffset = 2


    For Each Key In dicNew.Keys
        With Sheets(1).Columns("A")
            Set rngAdd = .Find(Key, , , xlWhole)
            If Not rngAdd Is Nothing Then
                strAddress = rngAdd.Address
                Do
                    intSum = intSum + rngAdd.Offset(0, PointsOffset)
                    Set rngAdd = .FindNext(rngAdd)
                Loop While Not rngAdd Is Nothing And rngAdd.Address <> strAddress
                dicNew(Key) = intSum
                intSum = 0
            End If
        End With
    Next Key


    Range(Cells(1, 5), Cells(dicNew.Count, 5)).Value = Application.Transpose(dicNew.Keys)
    Range(Cells(1, 6), Cells(dicNew.Count, 6)).Value = Application.Transpose(dicNew.Items)


    Set dicNew = Nothing


End Sub

With the above example i posted the output is:

John	27
Fred	9
Tim	12
Alex	47
Luke	11

<tbody>
</tbody>

 

[sandy666]

sure, good luck

 

[Fluff]

How about

Sub JumboCactuar()
   Dim Dic As Object
   Dim Ary As Variant, Tmp As Variant
   Dim i As Long, n As Long, a As Long, p As Long
   
   Set Dic = CreateObject("scripting.dictionary")
   Ary = Range("A1").CurrentRegion.Value2
   With Application
      n = .Match("Name", .Index(Ary, 1, 0), 0)
      a = .Match("Age", .Index(Ary, 1, 0), 0)
      p = .Match("Points", .Index(Ary, 1, 0), 0)
   End With
   For i = 2 To UBound(Ary)
      If Not Dic.Exists(Ary(i, n)) Then
         Dic.Add Ary(i, n), Array(Ary(i, a), Ary(i, p))
      Else
         Tmp = Dic(Ary(i, n))
         Tmp(1) = Tmp(1) + Ary(i, p)
         Dic(Ary(i, n)) = Tmp
      End If
   Next i
   Range("O2").Resize(Dic.Count).Value = Application.Transpose(Dic.Keys)
   Range("P2").Resize(Dic.Count, 2) = Application.Index(Dic.Items, 0, 0)
End Sub

 

[JumboCactuar]

Working perfectly thanks @Fluff

 

[Fluff]

You're welcome & thanks for the feedback