Consolidate column with same header but the header is in two rows

[gal12]

hello,

im trying to consolidate my data that have two headers, one under another and then the data in the same column.
i want that if the two headers are matching other two headers, to combine them to a single column.
i tried to improve this code but had no luck.

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

please help me

 

[Fluff]

How about

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)
 
                    Set Rg = Intersect(.Columns(c), Rg.EntireColumn)
                    If Not Rg Is Nothing Then Rg.Copy Cells(Rg.Rows.Count + 1, P)
 
                .Columns(c).Clear
            End If
        Next c
    End With
 
    Application.ScreenUpdating = True
End Sub

 

[gal12]

How about

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)

                    Set Rg = Intersect(.Columns(c), Rg.EntireColumn)
                    If Not Rg Is Nothing Then Rg.Copy Cells(Rg.Rows.Count + 1, P)

                .Columns(c).Clear
            End If
        Next c
    End With

    Application.ScreenUpdating = True
End Sub

thank you, but it didn't work because on of my header is a date...

 

[Fluff]

Are all the headers dates?

 

[gal12]

Are all the headers dates?

one date and one general text

 

[Fluff]

Ok, try

Sub ConsolidateColumns()
    Dim Rg As Range
    Application.ScreenUpdating = False
 
    With [A1].CurrentRegion
        For c& = 2 To .Columns.Count
        If IsDate(.Cells(c).Value) Then
            P& = Application.Match(CLng(.Cells(c).Value), .Rows(1), 0)
        Else
            P& = Application.Match(.Cells(c).Value, .Rows(1), 0)
        End If
            If P < c Then
                Set Rg = .Cells(c)
 
                    Set Rg = Intersect(.Columns(c), Rg.EntireColumn)
                    If Not Rg Is Nothing Then Rg.Copy Cells(Rg.Rows.Count + 1, P)
 
                .Columns(c).Clear
            End If
        Next c
    End With
 
    Application.ScreenUpdating = True
End Sub

 

[gal12]

Ok, try

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

    With [A1].CurrentRegion
        For c& = 2 To .Columns.Count
        If IsDate(.Cells(c).Value) Then
            P& = Application.Match(CLng(.Cells(c).Value), .Rows(1), 0)
        Else
            P& = Application.Match(.Cells(c).Value, .Rows(1), 0)
        End If
            If P < c Then
                Set Rg = .Cells(c)

                    Set Rg = Intersect(.Columns(c), Rg.EntireColumn)
                    If Not Rg Is Nothing Then Rg.Copy Cells(Rg.Rows.Count + 1, P)

                .Columns(c).Clear
            End If
        Next c
    End With

    Application.ScreenUpdating = True
End Sub

worked like a charm, thanks you

 

[Fluff]

You're welcome & thanks for the feedback.