I think my VBA Excel code is very inefficient

Question

I have a list of customer IDs (column B) and purchased products (column C). If the customer has bought more than one product, the cells beneath the customer ID are blank whilst col B lists on each row one product, until it runs out of purchased products for that customer. I want all of the products a customer has purchased in one row though, alongside their ID. (Column A is just a simple helper column, with a non-empty cell for each row of the table).

Code is not my natural area of expertise, but I wrote the below very simple macro to move all the products onto single rows, and delete the empty rows afterwards. However it's slow - it takes about a minute per 1,000 rows, and I have several hundred thousand rows to go through.

Is there any way to make it more efficient?

Sub RearrangeforR()

    Range("B1").Select

    Do While IsEmpty(Cells(ActiveCell.Row, 1)) = False

    If IsEmpty(ActiveCell) = True Then

        ActiveCell.Offset(0, 1).Select

        Selection.Copy

        ActiveCell.Offset(-1, 0).Select

            Do While IsEmpty(ActiveCell) = False

            ActiveCell.Offset(0, 1).Select

            Loop

        ActiveCell.PasteSpecial

        ActiveCell.Offset(1, 0).Select

        ActiveCell.EntireRow.Delete

        Cells(ActiveCell.Row, "B").Select

    Else: ActiveCell.Offset(1, 0).Select

    End If

Loop

End Sub

[Don't use `.Select`](http://stackoverflow.com/questions/10714251/how-to-avoid-using-select-in-excel-vba-macros) — BruceWayne, Jul 13 '16 at 14:43
combine some things, look at the Return of the function in the help file, for example, three lines to delete the row, could be `activecell.offset(1,0).entirerow.delete`, I think that could go to `activecell.entirerow.delete` `Actvecell.offset(1,0).copy` too and Use `.End(xlDown)` instead of the do while loop. and yes, avoid select — Nathan_Sav, Jul 13 '16 at 14:47
Also, as a way to speed it up quickly, turn off screen updating. Near the top of your macro, add `Application.ScreenUpdating = False` and at the end (before `End Sub`), add `Application.ScreenUpdating = True`. — BruceWayne, Jul 13 '16 at 15:14

score 0 · Answer 1 · 2016-07-13T18:03:29.077

It would be more efficient to collect the information in memory, delete all the rows at once, then copy the information back.
Here I add a Dictionary of Products to a Dictionary Customers. To process the customers and products.

Option Explicit

Sub CombineCustomerProducts()

    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
    End With

    Dim k As String
    Dim arr, key

    Dim lastRow As Long, x As Long
    Dim dictCustomers As Object, dictProducts

    Set dictCustomers = CreateObject("Scripting.Dictionary")

    lastRow = Range("C" & Rows.Count).End(xlUp).Row

    For x = 2 To lastRow
        k = Cells(x, 2)

        If Cells(x, 2).Value <> "" Then
         k = CStr(x)
         Set dictProducts = CreateObject("Scripting.Dictionary")

         dictProducts.Add "Key:" & dictProducts.Count, Cells(x, 1).Value
         dictProducts.Add "Key:" & dictProducts.Count, Cells(x, 2).Value

         dictCustomers.Add k, dictProducts

        End If

        dictProducts.Add "Key:" & dictProducts.Count, Cells(x, 3).Value

    Next

    Range("C2", Range("C" & Rows.Count).End(xlUp)).EntireRow.Delete

    x = 1

    For Each key In dictCustomers.Keys
        x = x + 1
        Set dictProducts = dictCustomers(key)
        arr = dictProducts.Items
        Cells(x, 1).Resize(1, UBound(arr) + 1) = arr
    Next

    With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
    End With
End Sub

You've got `.ScreenUpdating = False` and `.Calculation = xlCalculationManual` at the end. I think they should be `.ScreenUpdating = True` and `.Calculation = xlCalculationAutomatic`. — Chris Slade, Jul 13 '16 at 17:50

I think my VBA Excel code is very inefficient

1 Answers1