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

gal12

New Member
Joined
Feb 3, 2021
Messages
10
Office Version
  1. 2019
Platform
  1. Windows
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.

VBA Code:
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
 

Excel Facts

Can you sort left to right?
To sort left-to-right, use the Sort dialog box. Click Options. Choose "Sort left to right"

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
56,861
Office Version
  1. 365
Platform
  1. Windows
How about
VBA Code:
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

New Member
Joined
Feb 3, 2021
Messages
10
Office Version
  1. 2019
Platform
  1. Windows
How about
VBA Code:
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

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
56,861
Office Version
  1. 365
Platform
  1. Windows
Are all the headers dates?
 

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
56,861
Office Version
  1. 365
Platform
  1. Windows
Ok, try
VBA Code:
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

New Member
Joined
Feb 3, 2021
Messages
10
Office Version
  1. 2019
Platform
  1. Windows
Ok, try
VBA Code:
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

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
56,861
Office Version
  1. 365
Platform
  1. Windows
You're welcome & thanks for the feedback.
 

Watch MrExcel Video

Forum statistics

Threads
1,130,143
Messages
5,640,386
Members
417,139
Latest member
bdmprasenjit

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top