How can I add cell values based on column header? - excel

Question

I am having trouble grasping how the operation I'm about to describe can be conceptualized, since I am new to coding.
A big spreadsheet includes 100 columns, and those need to be condensed down to 10 by adding together the columns. There is a key, so that all the columns tagged with "1" go to 1st new column, and so on.
Here is an example:
There are n original columns. Each one of those columns has a key (bottom left), and according to that key it must be added to column 1, 2, 3, or 4 of the new table (bottom right). This is all nice and clean but the real spreadsheet has perhaps 270+ columns and they must be condensed into 10 columns or so for 3000+ ID's where not all ID's have all columns filled.
I am not sure how to create that sort of loop, I thought of looping through the key first, then finding in the original columns each "A", adding them to first column of new table, then doing that through all of them, but I'm not sure how to avoid overwriting old sums with the new ones.
Cheers!

Answer 1

You can do it with SUMPRODUCT. Actually, you can code it on VBA using this same formula of SUMPRODUCT and pasting values or with Evaluate:
=SUMPRODUCT(--($A$2:$A$6=$F14)*$B$2:$M$6*TRANSPOSE(--($B$14:$B$25=G$13)))
Depending on your Excel version maybe you need to input the formula as array formula, so instead of normally, type the formula and press CTRL+ENTER+SHIFT
UPDATE: You can also do it with VBA but you need to make some changes to your source file to make it work with any dataset of any size:
Your data must be alone in a worksheet called DATA
Your keys must be alone in a worksheet called KEYS
The code will generate a new worksheet with the grouped data according to keys. It uses same formula than before, but does it everything alone.
Sub TEST()
Dim wk As Worksheet
Dim rngData As Range
Dim rngKeys As Range
Dim LR As Long 'last non blank row
Dim LC As Long 'last non blank column
Dim ThisKeys As Variant
Set wk = ThisWorkbook.Sheets.Add(, ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)) 'add new worksheet for output at end of workbook
With ThisWorkbook.Worksheets("DATA")
LR = .Range("A" & .Rows.Count).End(xlUp).Row
LC = .Cells(1, .Columns.Count).End(xlToLeft).Column
Set rngData = .Range(.Cells(2, 2), .Cells(LR, LC))
.Range("A2:A" & LR).Copy wk.Range("A2:A" & LR) 'copy names to output
End With
With ThisWorkbook.Worksheets("KEYS")
LR = .Range("A" & .Rows.Count).End(xlUp).Row
Set rngKeys = .Range("B2:B" & LR)
.Range("B2:B" & LR).Copy
wk.Range("B2").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
End With
With wk
.Range("B2:B" & LR).RemoveDuplicates Columns:=1, Header:=xlNo
LR = .Range("B" & .Rows.Count).End(xlUp).Row
ThisKeys = .Range("B2:B" & LR).Value
.Range("B2:B" & LR).Clear
.Range("B1").Resize(1, UBound(ThisKeys)) = Application.WorksheetFunction.Transpose(ThisKeys) 'transpose keys to horizontal
.Range("A1").Value = "Names / Keys"
LR = .Range("A" & .Rows.Count).End(xlUp).Row
LC = .Cells(1, .Columns.Count).End(xlToLeft).Column
.Range("B2").FormulaArray = _
"=SUMPRODUCT(--(DATA!R2C1:R" & rngData.Rows.Count + 1 & "C1=RC1)*DATA!" & rngData.Address(True, True, xlR1C1) & "*TRANSPOSE(--(KEYS!R2C2:R" & rngKeys.Rows.Count + 1 & "C2=R1C)))"
.Range("B2").AutoFill Destination:=Range(.Range(.Cells(2, 2), .Cells(2, LC)).Address), Type:=xlFillDefault 'drag to right
.Range(.Cells(2, 2), .Cells(2, LC)).AutoFill Destination:=Range(.Range(.Cells(2, 2), .Cells(LR, LC)).Address), Type:=xlFillDefault 'drag to right
.Range(.Cells(2, 2), .Cells(LR, LC)).Value = .Range(.Cells(2, 2), .Cells(LR, LC)).Value 'paste as values, not formulas
End With
Erase ThisKeys
Set rngKeys = Nothing
Set rngData = Nothing
Set wk = Nothing
End Sub
I uploaded the file with the code so you can check it out: https://drive.google.com/file/d/1rc8oOPcqP4HBFEyamku24H9hHRFpncq_/view?usp=sharing