CODEWITHSUNDEEP
vbaexcel
MJ95
MJ95

Reputation: 479

Excel: Combining columns with similar values into one

Another not so easy problem. Using VBA, I need to iterate over the column headers which have similar names (not exact) and combine the values in the first one of that kind separated by ;.

Example data:

A (1) B (1) C (1) A (2) B (2) C (2) A(3) B (3) C (3) 
 15     25    35    45    100  200  300   600   700

Should dynamically be like this, deleting the extra columns (a lot of values are blank too which need to be accounted for:

A (1)            B (1)        C (1)  
15;45;300     25;100;600   35;200;700

EDIT: Changed data structure to be more accurate

I'm guessing first I need to loop and clean the data so they have the same name, because that's only thing to match on.

For i = 1 to lastCol Step 1
    columnVal = ws.Cells(1, i).Value
      If InStr(columnVal, "(") Then
         'Remove everything after first "("
      End If
       For j = 1 to lastCol
           For k = 1 to lastCol
              If ws.Cells(1, j).Value = ws.Cells(1, k).Value Then
                 'Create array with combined values
              End if
            Next k
        Next j

Not sure if this is the right approach so any help is appreciated

Upvotes: 0

Views: 57

Answers (1)

user3598756
user3598756

Reputation: 29421

you could go like follows:

Option Explicit

Sub main()
    With Worksheets("CombineColumns") '<--| change "CombineColumns" to your actual worksheet name
        With .Range("B2").CurrentRegion '<--| change "B2" to your actual topleftmost cell
            SortRange .Cells '<-- sort columns by their header
            .Rows(1).Replace what:="(*)", replacement:="(1)", lookat:=xlPart '<-- make all "similar" header the same
            Aggregate .Cells '<-- aggregate values under each different unique header
        End With
    End With
End Sub

Sub Aggregate(rng As Range)
    Dim header As String, resStrng As String
    Dim iLastCol As Long, iCol As Long

    With rng
        header = .Cells(1, 1).Value
        iCol = 2
        iLastCol = 1
        resStrng = .Cells(2, 1)
        Do
            If .Cells(1, iCol) = header Then
                resStrng = resStrng & ";" & .Cells(2, iCol)
            Else
                .Cells(2, iLastCol).Value = resStrng
                .Cells(1, iLastCol + 1).Resize(2, iCol - iLastCol - 1).ClearContents
                iLastCol = iCol
                resStrng = .Cells(2, iCol)
                header = .Cells(1, iCol).Value
            End If
            iCol = iCol + 1

        Loop While iCol <= .Columns.Count
        .Cells(2, iLastCol).Value = resStrng
        .Cells(1, iLastCol + 1).Resize(2, iCol - iLastCol - 1).ClearContents
        .EntireColumn.AutoFit
    End With
End Sub

Sub SortRange(rng As Range)
    With rng.Parent.Sort
        .SortFields.Clear
        .SortFields.Add Key:=rng.Rows(1), SortOn:=xlSortOnValues, order:=xlAscending, DataOption:=xlSortNormal

        .SetRange rng
        .header = xlYes
        .MatchCase = False
        .Orientation = xlLeftToRight
        .SortMethod = xlPinYin
        .Apply
    End With
End Sub

Upvotes: 1

Related Questions