If Column headers in row 1 are duplicated then copy all values into the first column header found.

Example;

To;

CodePudding user response：

Please, try the next code:

Sub CumulateSameColumnHeaders()
  Dim sh As Worksheet, lastR As Long, lastCol As Long, arrCols
  Dim i As Long, j As Long, colDel As Range, arrCopy
  
  Set sh = ActiveSheet 'use here the sheet you need
  lastCol = sh.cells(1, sh.Columns.count).End(xlToLeft).Column 'last column in the headers row
  arrCols = sh.Range("A1", sh.cells(1, lastCol)).Value         'place headers in an array (to iterate faster)
 
  For i = 1 To UBound(arrCols, 2)                              'iterate between the headers array elements
      For j = i   1 To UBound(arrCols, 2)                      'search the header between the next existing headers
            If arrCols(1, j) = arrCols(1, i) Then              'if the same header string has been found
                lastR = sh.cells(sh.rows.count, i).End(xlUp).row   1 'set the last (empty) row for the initial header column
                arrCopy = sh.Range(sh.cells(2, j), sh.cells(sh.rows.count, j).End(xlUp)).Value 'place the range to be copied in an array
                sh.cells(lastR, i).Resize(UBound(arrCopy), 1).Value = arrCopy  'drop the array content in the last empty row of the initial header
                If colDel Is Nothing Then                       'if range of header columns to be deleted is nothing
                    Set colDel = sh.cells(1, j)                 'set it as (second) header cell
                Else
                    Set colDel = Union(colDel, sh.cells(1, j))  'make a union between existing range and the next column to be deleted
                End If
            End If
      Next j
  Next i
  If Not colDel Is Nothing Then colDel.EntireColumn.Delete 'delete all columns to be eliminated, at once
End Sub