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

我有一个客户ID列表（B列）和购买的产品列表（C列）。如果客户购买了多个产品，则客户ID下方的单元格为空，而B栏在每行列出一个产品，直到该客户购买的产品售完为止。不过，我希望客户购买的所有产品都放在一行中，与他们的ID一起（a列只是一个简单的帮助器列，表中每行有一个非空单元格）

代码不是我的专业领域，但我编写了下面非常简单的宏，将所有产品移动到单行，然后删除空行。但是它很慢——每1000行大约需要一分钟，我有几十万行要通过

有没有办法使它更有效率

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

---

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

选项显式
子组合StomerProducts（）
应用
.ScreenUpdate=False
.Calculation=xlCalculationManual
以
调暗k为字符串
暗调
调暗最后一行的长度，x的长度
以客户为对象，以产品为对象
设置dictCustomers=CreateObject（“Scripting.Dictionary”）
lastRow=范围（“C”和Rows.Count）.End（xlUp）.Row
对于x=2到最后一行
k=单元（x，2）
如果单元格（x，2）.值为“”，则
k=CStr（x）
设置dictProducts=CreateObject（“Scripting.Dictionary”）
dictProducts.添加“键：”&dictProducts.计数，单元格（x，1）.值
dictProducts.添加“键：”&dictProducts.计数，单元格（x，2）.值
dictCustomers.addk，dictProducts
如果结束
dictProducts.添加“键：”&dictProducts.计数，单元格（x，3）.值
下一个
范围（“C2”，范围（“C”和行数）.End（xlUp））.EntireRow.Delete
x=1
为客户提供的每个密钥。密钥
x=x+1
设置dictProducts=dictCustomers（关键）
arr=产品。项目
单元格（x，1）。调整大小（1，UBound（arr）+1）=arr
下一个
应用
.ScreenUpdate=True
.Calculation=xlcalculation自动
以
端接头

结合一些东西，查看帮助文件中函数的返回，例如，删除行的三行可以是

activecell.offset（1,0）.entirerow.delete

，我认为可以转到

activecell.entirerow.delete

Actvecell.offset（1,0）.复制

并使用
.End（xlDown）
而不是执行while循环。是的，避免选择。另外，为了加快速度，关闭屏幕更新。在宏的顶部附近，添加
Application.screenUpdate=False
，并在末尾（在
end Sub
之前）添加
Application.screenUpdate=True
。最后是
。screenUpdate=False
和
。Calculation=xlCalculationManual
。我认为它们应该是
。屏幕更新=True
和
.Calculation=xlCalculationAutomatic
。谢谢克里斯。我被跟踪了。
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