Duplicate Removal mit einem Array in Vba

Question

Hallo habe ich einige Code aus einer Antwort auf eine Frage 'How do I delete duplicates between two excel sheets quickly vba' verwendet und habe versucht, diesen Code zu meinem eigenen VBA-Skript zu ändern. Der Code löscht Zeilen genauso wie im Array, löscht aber nur die ersten 11 Zeilen. Ich bin ziemlich neu bei VBA und verstehe nicht ganz, warum es das tut. Unten ist eine Kopie des Skripts, das ich verwende.

Dim overLayWB As Workbook  'Overlay_workbook 
    Dim formattedWB As Workbook  'Formatted_workbook 
    Dim formattedWS As Worksheet 'Current active worksheet (Formatted) 
    Dim overLayWS As Worksheet  'Worksheet in OverLay 
    Dim lastRowFormatted As Long 
    Dim lastRowOverLay As Long 

    Dim targetArray, searchArray 
    Dim targetRange As Range 
    Dim x As Long 

    'Update these 4 lines if your target and search ranges change 
    Dim TargetSheetName As String: TargetSheetName = "Formatted" 
    Dim TargetSheetColumn As String: TargetSheetColumn = "G22" 
    Dim SearchSheetName As String: SearchSheetName = "Overlay" 
    Dim SearchSheetColumn As String: SearchSheetColumn = "G22" 



    'open Overlay workbook 
    Set overLayWB = Workbooks.Open("C:\Documents\Templates\Overlaye.xls") 'Path for workbook Overlay to copy from 
    Set formattedWS = Workbooks("Formatted").Sheets("DLT Formatted") 
    Set overLayWS = Workbooks("Overlay").Sheets("Overlay") 
    Set formattedWB = ThisWorkbook 

'Load target array 
    With formattedWS 
     Set targetRange = .Range(.Range(TargetSheetColumn & "7"), _ 
       .Range(TargetSheetColumn & Rows.Count).End(xlUp)) 
     targetArray = targetRange 
    End With 

'Load Search Array 
    With overLayWS 
     searchArray = .Range(.Range(SearchSheetColumn & "7"), _ 
       .Range(SearchSheetColumn & Rows.Count).End(xlUp)) 
    End With 


    Dim dict As Object 
    Set dict = CreateObject("Scripting.Dictionary") 
    'Populate dictionary from search array 
    If IsArray(searchArray) Then 
     For x = 1 To UBound(searchArray) 
      If Not dict.exists(searchArray(x, 1)) Then 
       dict.add searchArray(x, 1), 1 
      End If 
     Next 
    Else 
     If Not dict.exists(searchArray) Then 
      dict.add searchArray, 1 
     End If 
    End If 

    'Delete rows with values found in dictionary 
    If IsArray(targetArray) Then 
     'Step backwards to avoid deleting the wrong rows. 
     For x = UBound(targetArray) To 1 Step -1 
      If dict.exists(targetArray(x, 1)) Then 
       targetRange.Cells(x).EntireRow.Delete 
      End If 
     Next 
    Else 
     If dict.exists(targetArray) Then 
      targetRange.EntireRow.Delete 
     End If 
    End If 

jemand mit mir dabei helfen kann es viel appreicated würde, ich habe das Scripting nicht korrekt geändert oder es etwas fehlt?

Answer 1

Es scheint, auf dieser Seite fast Weisheit erhalten zu haben, dass die Aufgabe zum Löschen von Zeilen am besten erreicht wird, indem man eine Range von unten nach oben durchläuft und jede einzelne Zeile löscht, wenn Kriterien erfüllt sind. Aber das ist wirklich eine ziemlich ineffiziente Methode. Vergleichen dieser beiden Schnipsel, zum Beispiel:

Dim r As Long 
Dim clock As cTimer 

Set clock = New cTimer 

clock.StartCounter 
Application.ScreenUpdating = False 
For r = 1 To 10000 
    Sheet1.Cells(1, 1).EntireRow.Delete 
Next 
Application.ScreenUpdating = True 
Debug.Print "Row by row:"; clock.TimeElapsed; "ms" 

clock.StartCounter 
Application.ScreenUpdating = False 
Sheet1.Range("A1:A10000").EntireRow.Delete 
Application.ScreenUpdating = True 
Debug.Print "Range:"; clock.TimeElapsed; "ms" 

Output ist wie folgt:

Zeile für Zeile: 2876,18174935641 ms

Bereich: 15,2153416146466 ms

Diese Ergebnisse aren‘ Es ist überraschend, dass es wahrscheinlich fair ist zu verallgemeinern, dass je größer die Anzahl der einzelnen Interaktionen mit einer Worksheet, desto langsamer die p Programm wird sein.

Was ist eine Schande ist, dass einige der Beiträge mit Entfernen von Duplikaten große Anstrengungen unternehmen, um Worksheet Werte zu lesen und Elemente in Arrays zu verweisen, um übermäßige Blattwechselwirkungen zu vermeiden. Und dennoch gehen all diese Effizienzgewinne durch ineffiziente Zeilenlöschung verloren. Was irreführend ist, ist, dass diese Beiträge manchmal "schnell" sein sollen.

Einige argumentieren, dass sie Aufgaben auf der Worksheet zwischen Zeilenlöschungen ausführen möchten. Die VBA-Bereiche aktualisieren jedoch ihre Adressen auf die gleiche Weise wie ein Excel-Formelbereich.Werfen Sie einen Blick auf den Code unten für ein Beispiel hierfür:

Dim cell As Range 

Set cell = Sheet1.Range("A3") 
Debug.Print "Address before deletion:"; cell.Address 
Sheet1.Range("A1").EntireRow.Delete 
Debug.Print "Address after deletion:"; cell.Address 

Ausgang ist:

Adresse vor dem Löschen: 3 $ A $

Adresse nach dem Löschen: 2 $ A $

Der folgende Code würde also immer noch die Zellen "A4" und "A6" und die ursprünglichen Zellen "A8" und "A10" löschen, zum Beispiel:

Dim rng1 As Range 
Dim rng2 As Range 

Set rng1 = Sheet1.Range("A4, A6") 
Set rng2 = Sheet1.Range("A8, A10") 
rng1.EntireRow.Delete 
Sheet1.Range("A5").Insert xlDown 
rng2.EntireRow.Delete 

Für eine praktische Anwendung könnte das OP wirklich die Frage beantworten "Wie lösche ich Duplikate zwischen zwei Excel-Tabellen schnell vba"? mit dem folgenden Code:

Private Sub RemoveMatchingRowsAsBatch(refRange As Range, targetRange As Range) 
    Dim refValues As Variant 
    Dim refItems As Collection 
    Dim refIndex As Long 
    Dim refKey As String 
    Dim targetValues As Variant 
    Dim targetIndex As Long 
    Dim targetKey As String 
    Dim test As Variant 
    Dim delRows As Range 
    Dim added As Boolean 

    'Read datasets into arrays 
    refValues = refRange.Value2 
    targetValues = targetRange.Value2 

    'Loop through target values and check if items match 
    Set refItems = New Collection 
    For targetIndex = 1 To UBound(targetValues, 1) 
     If Not IsEmpty(targetValues(targetIndex, 1)) Then 
      targetKey = CStr(targetValues(targetIndex, 1)) 
      test = Empty: On Error Resume Next 
      test = refItems(targetKey): On Error GoTo 0 

      'Check if existing ref item list has a match 
      If Not IsEmpty(test) Then 
       targetRange.Cells(targetIndex, 1).EntireRow.Delete 
       If delRows Is Nothing Then 
        Set delRows = targetRange.Cells(targetIndex, 1) 
       Else 
        Set delRows = Union(delRows, targetRange.Cells(targetIndex, 1)) 
       End If 
      Else 
       'There is no match so continue reading the reference list. 
       Do While refIndex < UBound(refValues, 1) 
        refIndex = refIndex + 1 
        If Not IsEmpty(refValues(refIndex, 1)) Then 
         'Test that the new reference item isn't itself a duplicate. 
         refKey = CStr(refValues(refIndex, 1)) 
         On Error Resume Next 
         refItems.Add refKey, refKey 
         added = Err.Number = 0 
         On Error GoTo 0 
         'It isn't a duplicate so check for a match. 
         If added Then 
          If refKey = targetKey Then 
           If delRows Is Nothing Then 
            Set delRows = targetRange.Cells(targetIndex, 1) 
           Else 
            Set delRows = Union(delRows, targetRange.Cells(targetIndex, 1)) 
           End If 
           Exit Do 
          End If 
         End If 
        End If 
       Loop 


      End If 
     End If 
    Next 

    'Now delete all rows in one 'batch'. 
    If Not delRows Is Nothing Then 
     delRows.EntireRow.Delete 
    End If 

End Sub 

In der Tat gibt es auch einige Missverständnisse über die Rolle und Funktion der Variablen im Code des OP und anderen Befragten haben bereits darauf hingewiesen, diese aus. im Interesse der Vollständigkeit, eine richtige Leseroutine jedoch für ihre/seine zwei Worksheets könnte so etwas wie die unten sein:

Public Sub ReadSheets() 
    Dim refFilePath As String 
    Dim refBookName As String 
    Dim refBook As Workbook 
    Dim refSheet As Worksheet 
    Dim refSheetName As String 
    Dim refCol As String 
    Dim refRow As Long 
    Dim refRange As Range 
    Dim refValues As Variant 
    Dim targetBook As Workbook 
    Dim targetSheet As Worksheet 
    Dim targetSheetName As String 
    Dim targetCol As String 
    Dim targetRow As Long 
    Dim targetRange As Range 
    Dim targetValues As Variant 

    'Define your sheet variables. 
    refFilePath = "Z:\ambie\VBA" 
    refBookName = "reference.xlsx" 
    refSheetName = "data" 
    refCol = "A" 
    refRow = "2" 
    targetSheetName = "uniques" 
    targetCol = "B" 
    targetRow = "3" 

    'Define the Excel the sheet objects. 
    On Error Resume Next 
    Set refBook = Workbooks(refBookName) 
    On Error GoTo 0 
    If refBook Is Nothing Then 
     Set refBook = Workbooks.Open(refFilePath & "\" & refBookName) 
    End If 
    Set refSheet = refBook.Worksheets(refSheetName) 
    Set targetBook = ThisWorkbook 
    Set targetSheet = targetBook.Worksheets(targetSheetName) 

    'Read both datasets. 
    With refSheet 
     Set refRange = .Range(.Cells(refRow, refCol), _ 
           .Cells(.Rows.Count, refCol).End(xlUp)) 
    End With 

    With targetSheet 
     Set targetRange = .Range(.Cells(targetRow, targetCol), _ 
           .Cells(.Rows.Count, targetCol).End(xlUp)) 
    End With 

    'Call the removal routine here 
    RemoveMatchingRowsAsBatch refRange, targetRange 
End Sub 

Answer 2

Das sieht aus:

With formattedWS 
    Set targetRange = .Range(.Range(TargetSheetColumn & "7"), _ 
      .Range(TargetSheetColumn & Rows.Count).End(xlUp)) 
    targetArray = targetRange 
End With 

mit Ihren gelieferten Werte, die sie übersetzt:

With formattedWS 
    Set targetRange = .Range(.Range("G227"), _ 
      .Range("G221048576").End(xlUp)) 
    targetArray = targetRange 
End With 

Ich glaube nicht, dass das, was Sie wollten, und einen Fehler melden sollte.