最後のエントリを保持する、重複を削除する -

Question

私はスプレッドシートを通過し、2つの列（列QとD）で別々に提供される2つの基準に基づいて重複するエントリ（行）を削除するマクロを作成しています。

これは私が持っているものです。小さなデータセットでテストしましたが、が遅いです。

Sub RemoveDupesKeepLast() 
dim i As Integer 
dim criteria1, criteria2 As String 

Application.ScreenUpdating = False 
Application.Calculation = xlCalculationManual 
Application.EnableEvents = False 

'start at bottom of sheet, go up 
For i = ActiveSheet.UsedRange.Rows.Count to 2 Step -1 

    'if there is no entry, go to next row 
    If Cells(i, "Q").Value = "" Then 
     GoTo gogo: 
    End If 

    'set criteria that we will filter for 
    criteria1 = Cells(i, "D").Value 
    criteria2 = Cells(i, "Q").Value 

    'filter for criteria2, then criteria1 to get duplicates 
    ActiveSheet.Range("A":"CI").AutoFilter field:=17, Criteria1:=criteria2, Operator:=xlFilterValues 
    ActiveSheet.Range("A":"CI").AutoFilter field:=4, Criteria1:=criteria1, Operator:=xlFilterValues 

    'if there are duplicates, keep deleting rows until only bottom-most entry is left behind 
    Do While Range("Q2", Cells(Rows.Count, "Q").End(xlUp)).Cells.SpecialCells(xlCellTypeVisible).Count > 1 
     ActiveSheet.AutoFilter.Range.Offset(1).SpecialCells(xlCellTypeVisible).Cells(1,17).EntireRow.Delete 
    Loop 

    'reset autofilter 
    If ActiveSheet.FilterMode Then 
     Cells.AutoFilter 
    End If 

gogo: 
Next i 

Application.EnableEvents = True 
Application.Calculation = xlCalculationAutomatic 
Application.ScreenUpdating = True 

End Sub 

私はこの問題に近づき、状況を速めることができますか？今のように、私は基本的に各行をチェックしてから上に行きます。シートは、実際には30,000行から最大限までです。私がやろうとしていることをより速く、よりクリーンな方法で達成すべきだと思うが、私は考えることができない。

Answer 1

100,00行は40.3秒で87個の列が×。

データセットが30K行から始まり、より大きくなる場合は、可能な限りメモリ内処理を検討する必要があります.¹私はthis solutionで使用されているメソッドをあなたの必要条件にもっと近づけるように改造しました。

次のバルクはすべての値をバリアント配列にロードし、結果からScripting.Dictionaryオブジェクトを作成します。辞書にキーを追加する「上書き」方法は、最後のものだけが保持されるように使用される。

照合が実行されると、値は再ディメンション化されたバリアント配列に戻され、ワー​​クシートマージに復元されます。 Module1 (Code)

Option Explicit 

Sub removeDupesKeepLast() 
    Dim d As Long, dDQs As Object, ky As Variant 
    Dim r As Long, c As Long, vVALs As Variant, vTMP As Variant 

    'appTGGL bTGGL:=False 'uncomment this when you have finished debugging 

    Set dDQs = CreateObject("Scripting.Dictionary") 
    dDQs.comparemode = vbTextCompare 

    'step 1 - bulk load the values 
    With Worksheets("Sheet1") 'you should know what worksheet you are on 
     With .Cells(1, 1).CurrentRegion 'block of data radiating out from A1 
      With .Resize(.Rows.Count - 1, .Columns.Count).Offset(1, 0) 'step off the header row 
       vVALs = .Value 'use .Value2 if you do not have dates in unformatted cells 
      End With 
     End With 
    End With 

    'step 2 - build the dictionary 
    ReDim vTMP(UBound(vVALs, 2) - 1) 
    For r = LBound(vVALs, 1) To UBound(vVALs, 1) 
     For c = LBound(vVALs, 2) To UBound(vVALs, 2) 
      vTMP(c - 1) = vVALs(r, c) 
     Next c 
     dDQs.Item(vVALs(r, 4) & ChrW(8203) & vVALs(r, 17)) = vTMP 
    Next r 

    'step 3 - put the de-duplicated values back into the array 
    r = 0 
    ReDim vVALs(1 To dDQs.Count, LBound(vVALs, 2) To UBound(vVALs, 2)) 
    For Each ky In dDQs 
     r = r + 1 
     vTMP = dDQs.Item(ky) 
     For c = LBound(vTMP) To UBound(vTMP) 
      vVALs(r, c + 1) = vTMP(c) 
     Next c 
    Next ky 

    'step 4 - clear the destination; put the de-duplicated values back into the worksheet and reset .UsedRange 
    With Worksheets("Sheet1") 'you should know what worksheet you are on 
     With .Cells(1, 1).CurrentRegion 'block of data radiating out from A1 
      With .Resize(.Rows.Count - 1, .Columns.Count).Offset(1, 0) 'step off the header row 
       .ClearContents 'retain formatting if it is there 
       .Cells(1, 1).Resize(UBound(vVALs, 1), UBound(vVALs, 2)) = vVALs 
      End With 
     End With 
     .UsedRange 'assert the UsedRange property (refreshes it) 
    End With 

    dDQs.RemoveAll: Set dDQs = Nothing 

    appTGGL 
End Sub 

Public Sub appTGGL(Optional bTGGL As Boolean = True) 
    With Application 
     .ScreenUpdating = bTGGL 
     .EnableEvents = bTGGL 
     .DisplayAlerts = bTGGL 
     .AutoRecover.Enabled = bTGGL 'no interruptions with an auto-save 
     .Calculation = IIf(bTGGL, xlCalculationAutomatic, xlCalculationManual) 
     .CutCopyMode = False 
     .StatusBar = vbNullString 
    End With 
    Debug.Print Timer 
End Sub 

は私のサンプルブックには、〜24％の重複で87列×100K行を取って〜40秒で（最後のエントリを保つ）すべての重複を処理しました。上記は、Sheet1に書き戻されます。私のテストは元のデータを保持するためにSheet2に書き戻されて実行されました。別のワークシートに書き戻す場合は、Range.CurrentRegion propertyを正しく識別できるように、A1から始まる値がいくつかあることを確認してください。テストマシンは、32ビットExcel 2010を実行する古いラップトップでした。自分の結果は変わる可能性があります。

---

は _{Excelで大規模なデータセットを扱う上で先端[S用Highlight Duplicates and Filter by color alternativeを参照してください¹しました。}

Answer 2

この手順では、D列とQ列で識別される重複行をすべて削除します。 重複行の中では、行が用紙の最下部に最も近い状態に保たれます。 基本的には、インデックス付きの列が右側に作成され、すべての重複行が一番下に並べ替えられ、1回の呼び出しで削除できます。 セルの数式または書式がある場合は変更しないことに注意してください。

Sub DeleteDuplicatedRows() 
    Dim rgTable As Range, rgIndex As Range, dataColD(), dataColQ() 

    Set rgTable = ActiveSheet.UsedRange 

    ' load each column representing the identifier in an array 
    dataColD = rgTable.Columns("D").value ' load values from column D 
    dataColQ = rgTable.Columns("Q").value ' load values from column Q 

    ' get each unique row number with a dictionary 
    Dim dict As New VBA.collection, indexes(), r&, rr 
    On Error Resume Next 
    For r = UBound(dataColD) To 1 Step -1 
    dict.Add r, dataColD(r, 1) & vbNullChar & dataColQ(r, 1) 
    Next 
    On Error GoTo 0 

    ' index all the unique rows in an array 
    ReDim indexes(1 To UBound(dataColD), 1 To 1) 
    For Each rr In dict: indexes(rr, 1) = rr: Next 

    ' insert the indexes in the last column on the right 
    Set rgIndex = rgTable.Columns(rgTable.Columns.count + 1) 
    rgIndex.value = indexes 

    ' sort the rows on the indexes, duplicates will move at the end 
    Union(rgTable, rgIndex).Sort key1:=rgIndex, Orientation:=xlTopToBottom, Header:=xlYes 

    ' delete the index column on the right and the empty rows at the bottom 
    rgIndex.EntireColumn.Delete 
    rgTable.Resize(UBound(dataColD) - dict.count + 1).offset(dict.count).EntireRow.Delete 

End Sub