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 Range("G2").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 Loop Next Var Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic Application.EnableEvents = True
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 Do 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?
ThisWorkbook.Sheets("Sheet1").Cells.ClearContents 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 Next ' 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 Loop ' delete the column we used to keep track of the number of values ThisWorkbook.Worksheets("Sheet1").Columns(2).Delete 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#" Err.Clear Else 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 bannana orange plum b apple berry grapefruit orange c berry kiwi melon
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).