LinkBack URL
About LinkBacks
Pandrade 
Hi,
I need a macro that will combine the data for the columns with headers that have the same name. In the attached example I would end up with three columns, one for MUN, one for PRT, and one for GAM.
Thank you for your help.
Hi,
I need a macro that will combine the data for the columns with headers that have the same name. In the attached example I would end up with three columns, one for MUN, one for PRT, and one for GAM.
Thank you for your help.
And what is the expected result?
Try this and we can modify it later:
Sub CombHeads(): Dim r As Long, c As Long Dim m As Long, n As Long, wa As Worksheet Set wa = ActiveWorkbook.Sheets("Sheet1") r = wa.Rows.Find("*", , , , xlByRows, xlPrevious).Row c = wa.Columns.Find("*", , , , xlByColumns, xlPrevious).Column Cells(1, c + 2).Resize(1, 3) = Split("MUN PRT GAM") For m = 2 To r: For n = 1 To c If Cells(m, n) Then Select Case Cells(1, n) Case "MUN": Cells(m, c + 2) = Cells(m, c + 2) + Cells(m, n) Case "PRT": Cells(m, c + 3) = Cells(m, c + 3) + Cells(m, n) Case "GAM": Cells(m, c + 4) = Cells(m, c + 4) + Cells(m, n) End Select End If: Next n: Next m: End Sub
Last edited by xladept; 04-18-2020 at 12:54 PM.
If I've helped you, please consider adding to my reputation - just click on the liitle star at the left.
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~(Pride has no aftertaste.)
You can't do one thing. XLAdept
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~aka Orrin
or dynamic
Sub VenA() ar = Sheet1.Cells(1).CurrentRegion ReDim ar1(1, 0) For j = 2 To UBound(ar) For jj = 1 To UBound(ar, 2) If ar(j, jj) <> "" Then ar1(0, t) = ar(1, jj) ar1(1, t) = ar(j, jj) t = t + 1 ReDim Preserve ar1(1, t) End If Next jj Next j With Sheet2 .Cells.Clear .Cells(1).Resize(, 2) = Array("Type", "Value") .Cells(1).Offset(1).Resize(t, 2) = Application.Transpose(ar1) End With End Sub
Hi ! Try this !
Or the Excel way as a VBA beginner starter :
PHP Code:Sub Demo1()
Dim C%, P%, S$
With ActiveSheet.UsedRange
For C = 2 To .Columns.Count
P = Application.Match(.Cells(C), .Rows(1), 0)
If P < C Then
Range(.Cells(2, C), .Cells(C).End(xlDown)).Copy .Cells(P).End(xlDown)(2)
S = IIf(S > "", S & ",", "") & .Cells(C).Address(0, 0)
End If
Next
End With
If S > "" Then Range(S).EntireColumn.Delete
End Sub
► Do you like it ? ► ► So thanks to click on bottom left star icon « ★ Add Reputation » ! ◄ ◄
Vraag en antwoord,
Not quite what I need. The data should not be summed just combined into one column per header. The attached file is what the end result should be.
The data should stack into one column if the column has the same name as in the attached file in reply #6. Hope someone can help.
Re: Macro to Combine data for Columns with same header
Originally Posted by Pandrade
As you already got a solution in post #5 ‼
Another try:
Sub CombOnlyHeads(): Dim r As Long, c As Long, X As Range Dim m As Long, n As Long, s As Long, t As Long, u As Long Dim wa As Worksheet: Set wa = ActiveWorkbook.ActiveSheet s = 2: t = 2: u = 2 c = wa.Columns.Find("*", , , , xlByColumns, xlPrevious).Column Cells(1, c + 2).Resize(1, 3) = Split("MUN PRT GAM") For n = 1 To c: Set X = wa.UsedRange.Columns(n) m = WorksheetFunction.CountA(X) - 1 Select Case Cells(1, n) Case "MUN": Cells(s, c + 2).Resize(m, 1).Value = _ Cells(2, n).Resize(m, 1).Value: s = s + m Case "PRT": Cells(t, c + 3).Resize(m, 1).Value = _ Cells(2, n).Resize(m, 1).Value: t = t + m Case "GAM": Cells(u, c + 4).Resize(m, 1).Value = _ Cells(2, n).Resize(m, 1).Value: u = u + m End Select Next n wa.Columns("A:" & Chr(65 + c)).Delete End Sub
There are currently 1 users browsing this thread. (0 members and 1 guests)
Posting Permissions
Register To Reply
Bookmarks