私のVBA Excelコードは非常に非効率的だと思います

Question

私は顧客ID（列B）と購入した製品（列C）のリストを持っています。顧客が複数の製品を購入した場合、顧客IDの下のセルは空白になりますが、col Bはその顧客の購入商品がなくなるまで、各行に1つの製品をリストします。私は顧客が購入したすべての商品を、IDと並んで1列に入れたい。 （列Aは単なるヘルパー列に過ぎず、表の各行には空ではありません）。

コードは私の自然な専門分野ではありませんが、私は以下の非常に単純なマクロを書いて、すべての製品を単一の行に移動し、後で空の行を削除します。しかし、それは遅いです - それは1,000行あたり約1分かかります、そして、私は通過する数十万の行を持っています。

これを効率的にする方法はありますか？

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

メモリ内の情報を収集し、すべての行を一度に削除し、情報を元に戻す方が効率的です。
ここでは、Dictionary of ProductsをDictionary Customersに追加します。顧客と製品を処理する。

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