我认为我的VBA Excel代码效率很低

Question

我有一个客户ID（B列）和购买的产品（C列）的列表。 如果客户购买了不止一种产品，则客户ID下方的单元格为空白，而B行在每一行上列出一种产品，直到用完该客户的已购买产品为止。 我希望客户已将所有产品和ID一起购买。 （列A只是一个简单的帮助程序列，表的每一行都有一个非空单元格）。

代码不是我的专长，但是我写了下面一个非常简单的宏，将所有产品移到单行，然后删除空行。 但是它很慢-每1,000行大约需要一分钟，而我要经历数十万行。

有什么办法可以提高效率？

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

Answer 1

收集内存中的信息，一次删除所有行，然后将信息复制回来，效率会更高。
在这里，我将产品词典添加到词典客户。 处理客户和产品。

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