Excel VBA Combine Columns based on headers-CodePudding

I am strugggeling with creating a VBA macro, which combines the Data of Columns based on the header.

Output should be: Output (Lemon Values U I O P - wrong in the screenshot)

Also I don't have a fixed range for this data table, which gives me a headache :)

Hope someone can help me out here !

This is what I currently have:

With wb.Sheets("Sheet1").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

CodePudding user response：

Use nested Dictionaries for uniqueness.

Option Explicit

Sub Macro1()

    Dim wb As Workbook, wsIn As Worksheet, wsOut As Worksheet
    Dim ar, dict As Object, k, val
    Dim i As Long, j As Long, hdr As String
    
    Set dict = CreateObject("Scripting.Dictionary")
    Set wb = ThisWorkbook
    
    ' input data into array
    Set wsIn = wb.Sheets("Sheet1")
    ar = wsIn.UsedRange
    
    ' scan array elements into dict/collection
    For j = 1 To UBound(ar, 2)
        hdr = Trim(ar(1, j))
        For i = 2 To UBound(ar)
            If Not dict.exists(hdr) Then
                dict.Add hdr, CreateObject("Scripting.Dictionary")
            End If
            
            val = ar(i, j)
            If Len(val) > 0 Then
                 dict(hdr)(val) = 1 ' add to keys
            End If
        Next
    Next
    
    ' output
    i = 0
    j = 0
    Set wsOut = wb.Sheets("Sheet2")
    With wsOut
        For Each k In dict
            j = j   1
            i = 1
            .Cells(i, j) = k
            For Each val In dict(k)
                i = i   1
                .Cells(i, j) = val
            Next
        Next
     End With
 End Sub