Consolidate columns with the same headers

[skyr]

Hi guys,

I am trying to consolidate data from columns which have same headers in the one worksheet. But I got no clue how to achieve that. I have googled about this problem without success.

Here is the sample sheet.

Thank you so much!

 

[Marc L]

Hi,​

​

googling is almost never the solution, the better is using your brain !​

​

Sub ConsolidateColumns()
    Dim Rg As Range
    Application.ScreenUpdating = False

    With [A1].CurrentRegion
        For C& = 2 To .Columns.Count
            P& = Application.Match(.Cells(C).Value, .Rows(1), 0)

            If P < C Then
                Set Rg = .Cells(C).End(xlDown)
                Range(Rg, Rg.End(xlDown)).Cut Cells(Rg.Row, P)
                .Cells(C).Clear
            End If
        Next C
    End With

    Application.ScreenUpdating = True
                        Set Rg = Nothing
End Sub

Like it !​

 

[skyr]

Hi,​

​

googling is almost never the solution, the better is using your brain !​

​

Sub ConsolidateColumns()
    Dim Rg As Range
    Application.ScreenUpdating = False
 
    With [A1].CurrentRegion
        For C& = 2 To .Columns.Count
            P& = Application.Match(.Cells(C).Value, .Rows(1), 0)
 
            If P < C Then
                Set Rg = .Cells(C).End(xlDown)
                Range(Rg, Rg.End(xlDown)).Cut Cells(Rg.Row, P)
                .Cells(C).Clear
            End If
        Next C
    End With
 
    Application.ScreenUpdating = True
                        Set Rg = Nothing
End Sub

Like it !​

Hi Marc, thank you for your code. It works great! However it doesn't look right with non-contiguous range.

 

[Marc L]

​

Exact ! But the code is based on your sample sheet …​

​

New code upon last one :​

Sub ConsolidateColumns()
    Dim Rg As Range
    Application.ScreenUpdating = False
 
    With [A1].CurrentRegion
        For C& = 2 To .Columns.Count
            P& = Application.Match(.Cells(C).Value, .Rows(1), 0)
 
            If P < C Then
                Set Rg = .Cells(C)
 
                Do
                    Set Rg = Intersect(.Columns(C), Rg.End(xlDown))
                    If Not Rg Is Nothing Then Rg.Copy Cells(Rg.Row, P)
                Loop Until Rg Is Nothing
 
                .Columns(C).Clear
            End If
        Next C
    End With
 
    Application.ScreenUpdating = True
End Sub

Like it ?​

 

[skyr]

thanks Marc !

 

[Smallman]

Skyr

Is your data always sequential by header? If so based on your file then this;

Sub Del()
    [a1].CurrentRegion.Offset(1).SpecialCells(4).Delete xlToLeft
    Range(Cells(1, [iv2].End(1).Column + 1), Cells(1, [iv1].End(1).Column)).Clear
End Sub

Take care

Smallman

 

[skyr]

Skyr

Is your data always sequential by header? If so based on your file then this;

Sub Del()
    [a1].CurrentRegion.Offset(1).SpecialCells(4).Delete xlToLeft
    Range(Cells(1, [iv2].End(1).Column + 1), Cells(1, [iv1].End(1).Column)).Clear
End Sub

Take care

Smallman

Thanks Smallman. Unfortunately, the header is not sequential, it is by random