VBA for combining duplicate columns and sum the value in different cells

[darrenliux]

Hi
I'm looking for a VBA code to solve the problem below, the input will start in Cell I2. I'd really appreciate any help on this.
Raw input table:

	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R
1
2									2000	2001	2002	2003	2000	2001	2002	2003	... to continue up to 30 columns
3									1	2	3	4	9	9	9	9
4
5
6

<tbody>
</tbody>

to consolidate data to (Solution is under the original data)

	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R
1
2									2000	2001	2002	2003	2000	2001	2002	2003	...to continue up to 30 columns
3									1	2	3	4	9	9	9	9
4									2000	2001	2002	2003
5									10	11	12	13
6

<tbody>
</tbody>

Thank you in advance for any help

 

[JLGWhiz]

Sub t()
    With ActiveSheet
        For i = 9 To 12
            .Cells(4, i) = .Cells(2, i).Value
            .Cells(5, i) = Application.SumIf(.Cells(2, i).Resize(, 30), .Cells(2, i).Value, .Cells(3, i).Resize(, 30))
        Next
    End With
End Sub

 

[darrenliux]

Sub t()
    With ActiveSheet
        For i = 9 To 12
            .Cells(4, i) = .Cells(2, i).Value
            .Cells(5, i) = Application.SumIf(.Cells(2, i).Resize(, 30), .Cells(2, i).Value, .Cells(3, i).Resize(, 30))
        Next
    End With
End Sub

Hi JLGWhiz,
Thank you very much for your code.
I've just tried it. The first 4 years worked perfectly.
However, because there are more than 4 different years in my data, the rest of the years don't appear. (please see below)
Could you please have a look and update it if possible. Many thanks.

2005	2006	2008	2018	2016	2018	2005	2006	2008	2010	2010	2006
5	1	7	2	8	9	6	5	6	2	7	10
2005	2006	2008	2018
11	16	13	11

<colgroup><col><col><col span="2"><col><col><col><col><col><col><col><col></colgroup><tbody>
</tbody>

 

[JLGWhiz]

Two questions
1. How many unique years do you have on the row?

2. Do they run consescutively before starting to repeat, or are they randomly distributed?

 

[JLGWhiz]

Disregard post #4 . Try this version.

Sub t2()
Dim lr As Long, c As Range, col As Long
lr = ActiveSheet.Cells.Find("*", , xlValues, xlPart, xlByRows, xlPrevious).Row
With ActiveSheet
    .Range("I2", .Cells(2, Columns.Count).End(xlToLeft)).Copy
    .Cells(lr + 2, 1).PasteSpecial xlPasteValues, Transpose:=True
    .Cells(lr + 2, 1).CurrentRegion.AdvancedFilter xlFilterCopy, , .Cells(lr + 2, 3), True
    .Cells(lr + 2, 1).CurrentRegion.ClearContents
    .Cells(lr + 2, 3).CurrentRegion.Sort .Cells(lr + 2, 3), xlAscending
    col = 9
    For Each c In .Cells(lr + 2, 2).CurrentRegion.Offset(1)
        If c <> "" Then
            .Cells(4, col) = c.Value
            .Cells(5, col) = Application.SumIf(.Cells(2, col).Resize(, 30), c.Value, .Cells(3, col).Resize(, 30))
            col = col + 1
        End If
    Next
    .Cells(lr + 2, 2).CurrentRegion.ClearContents
End With
End Sub

 

[darrenliux]

Hi JLGWhiz
Thank you again for the code.
There are still a bit error when I tried it.
Year 1989 is missing, and it returns 0 for some of the years.

2001	2006	2018	2005	2003	2009	2001	2007	2017	2015	2015	1989	2003	2006	1989	2003
2	2	3	6	5	3	9	8	7	12	14	6	1	1	1	1
2001	2001	2003	2005	2006	2007	2009	2015	2017	2018
11	9	7	6	1	8	0	26	7	0

<colgroup><col><col span="2"><col span="3"><col span="3"><col span="2"><col><col><col><col><col></colgroup><tbody>
</tbody>

 

[darrenliux]

Hi JLGWhiz
can you please amend the code, so that the solution overwrite the original data instead of below it.
Thank you.

 

[JLGWhiz]

I believe this fixes the skipped years and zero values. It does not overwrite the original values, but instead deletes the original values on rows 2 and 3 and shifts the new values up. If it had overwritten the original values, then you would have had some of the old values tagged onto the end of the new values, since there were more years entered for the original values.

Sub t3()
Dim lr As Long, lc As Long, c As Range, col As Long
lc = ActiveSheet.Cells(2, Columns.Count).End(xlToLeft).Column
lr = ActiveSheet.Cells.Find("*", , xlValues, xlPart, xlByRows, xlPrevious).Row
With ActiveSheet
    .Range("I2", .Cells(2, Columns.Count).End(xlToLeft)).Copy
    .Cells(lr + 2, 1).PasteSpecial xlPasteValues, Transpose:=True
    Application.CutCopyMode = False
    .Cells(lr + 2, 1).CurrentRegion.Sort .Cells(lr + 2, 1), xlAscending
    .Cells(lr + 2, 1).CurrentRegion.AdvancedFilter xlFilterCopy, , .Cells(lr + 2, 3), True
    .Cells(lr + 2, 1).CurrentRegion.ClearContents
    col = 9
    For Each c In .Cells(lr + 2, 3).CurrentRegion.Offset(1)
        If c <> "" Then
            .Cells(4, col) = c.Value
            .Cells(5, col) = Application.SumIf(.Range(.Cells(2, 9), .Cells(2, lc)), c.Value, .Range(.Cells(3, 9), .Cells(3, lc)))
            col = col + 1
        End If
    Next
    .Range(.Cells(2, 9), .Cells(3, lc)).Delete xlShiftUp
    .Cells(lr + 2, 3).CurrentRegion.ClearContents
End With
End Sub

 

[darrenliux]

Hi JLGWhiz
It's working brilliantly. Much appreciate it.

 

[JLGWhiz]

Hi JLGWhiz
It's working brilliantly. Much appreciate it.

Happy to help,
Regards, JLG