Home » excel » vba – Consolidating Columns in Excel

vba – Consolidating Columns in Excel

Posted by: admin May 14, 2020 Leave a comment


I have two columns in excel like the following


I need to consolidate them like this on a different sheet


Any help would be appreciated

This code works but is way too slow. I have to cycle through 300000 entries.

Dim MyVar As String
Dim Col
Dim Var

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False

    ' Select first line of data.
  For Var = 1 To 132536
  Sheets("Line Item Detail").Select
  ' Set search variable value.
  Var2 = "A" & Var

  MyVar = Sheets("Sheet1").Range(Var2).Value

  'Set Do loop to stop at empty cell.
  Col = 1
  Do Until IsEmpty(ActiveCell)
     ' Check active cell for search value.
     If ActiveCell.Value = MyVar Then

        Col = Col + 1
        Sheets("Sheet1").Range(Var2).Offset(0, Col).Value = ActiveCell.Offset(0, 1).Value

     End If
     ' Step down 1 row from present location.
     ActiveCell.Offset(1, 0).Select
  Next Var

 Application.ScreenUpdating = True
 Application.Calculation = xlCalculationAutomatic
 Application.EnableEvents = True
How to&Answers:

Your code is a good starting point. Couple things to speed it up.

Instead of using ActiveCell and SelectValue just change values directly like this:

Sheet1.Cells(1, 1) = "asdf"

Also, sort your sheet on the first (key) column before you start your loops (there is a VBA Sort method if you need to do this programatically). It might take a little time but will save you in the long run. Then your Do Until IsEmpty inner loop only has to go until the value of the key changes instead of through the entire data set every time. This reduces your run time an order of magnitude.

I have included some code below. It ran in about a minute for 300K random data lines. The sort took about 3 seconds. (I have a normal desktop – approx 3 years old).

Sort in VBA as follows Sheet1.Range("A1:B300000").Sort key1:=Sheet1.Range("A1"). You can also replace the Range param with two Cell params (see Excel help for examples).

Code for the processing. You might want to parameterize the sheet – I just hardcoded it for brevity.

    Dim LastKey As String
    Dim OutColPtr As Integer
    Dim OutRowPtr As Long
    Dim InRowPtr As Long
    Dim CurKey As String

    Const KEYCOL As Integer = 1         'which col holds your "keys"
    Const VALCOL As Integer = 2         'which col holds your "values"
    Const OUTCOLSTART As Integer = 4    'starting column for output

    OutRowPtr = 0   'one less than the row you want your output to start on
    LastKey = ""
    InRowPtr = 1    'starting row for processing

        CurKey = Sheet2.Cells(InRowPtr, KEYCOL)
        If CurKey <> LastKey Then
            OutRowPtr = OutRowPtr + 1
            LastKey = CurKey
            Sheet2.Cells(OutRowPtr, OUTCOLSTART) = CurKey
            OutColPtr = OUTCOLSTART + 1
        End If

        Sheet2.Cells(OutRowPtr, OutColPtr) = Sheet2.Cells(InRowPtr, VALCOL)
        OutColPtr = OutColPtr + 1
        InRowPtr = InRowPtr + 1

    Loop While Sheet2.Cells(InRowPtr, KEYCOL) <> ""


Could you give this a shot?

intKeyCount = 0
i = 1

' loop till we hit a blank cell
Do While ThisWorkbook.Sheets("Line Item Detail").Cells(i, 1).Value <> ""
    strKey = ThisWorkbook.Sheets("Line Item Detail").Cells(i, 1).Value

    ' search the result sheet
    With ThisWorkbook.Worksheets("Sheet1")
    For j = 1 To intKeyCount

        ' we're done if we hit the key
        If .Cells(j, 1).Value = strKey Then
            .Cells(j, 2).Value = .Cells(j, 2).Value + 1
            .Cells(j, .Cells(j, 2).Value).Value = ThisWorkbook.Sheets("Line Item Detail").Cells(i, 2).Value
            Exit For
        End If

    ' new key
    If j > intKeyCount Then
        intKeyCount = intKeyCount + 1
        .Cells(j, 1).Value = strKey
        .Cells(j, 3).Value = ThisWorkbook.Sheets("Line Item Detail").Cells(i, 2).Value
        ' keep track of which till which column we filled for the row
        .Cells(j, 2).Value = 3
    End If
    End With

    i = i + 1

' delete the column we used to keep track of the number of values

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True


Sorry I can’t be more helpful, I don’t have Excel handy.

Here is a related thread on the subject, using VBA:


And the snippet from that thread:

Function MultiVLookup(rngLookupValues As Range, strValueDelimiter As String, rngLookupRange As Range, TargetColumn As Integer) As String
Dim varSplitValues As Variant, varItem As Variant, strResult As String, i As Integer, varLookupResult As Variant

varSplitValues = Split(rngLookupValues, strValueDelimiter, -1, vbTextCompare)

For Each varItem In varSplitValues

    On Error Resume Next
    varLookupResult = Application.WorksheetFunction.VLookup(varItem, rngLookupRange, TargetColumn, False)

    If Err.Number <> 0 Then
        strResult = strResult & "#CompanyNameNotFound#"
        strResult = strResult & varLookupResult
    End If
    On Error GoTo 0

    If UBound(varSplitValues) <> i Then
        strResult = strResult & ", "
    End If
    i = i + 1
Next varItem

MultiVLookup = strResult

End Function


There is a pivot table-based approach you might want to consider.

Create a pivot table (if using Excel 2007, use the “classic” format) with both of your fields in the Row Labels area. Remove subtotals and grand totals. This will give you a unique list of all values for each of the categories. You can then copy and paste values to get your data in this format:

a   apple
b   apple
c   berry

All your unique values are now compactly displayed and you can use VBA to loop through this smaller subset of data.

If you need any help with the VBA for the pivot table creation, let me know.


This can be done by hand in less than 1 minute using pivot table and grouping.

  • create a pivot with the fruits as the row fields (the leftmost column)
  • move drag the fruits you want to group next to each other
  • to group, select the cells in the leftmost column, and select Group from the PivotTable menu
  • repeat previous point for each group

Now that you can do it the efficient way “by hand”, record it, and rewrite it properly, and you may end up with efficient code, using the facilities of its environment (Excel).