Question

我有一份客户ID列表（B栏）和购买的产品（C栏）。如果客户购买了多个产品，则客户ID下方的单元格为空白，而col 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

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

我认为我的VBA Excel代码非常低效

1 个答案: