Yinelenen kaldırma vba içinde bir dizi kullanarak kaldırma

Question

Merhaba, bir cevabın bir kodunu 'How do I delete duplicates between two excel sheets quickly vba' sorgusuna kullandım ve bu kodu kendi VBA komut dosyamda değiştirmeye çalıştım. Kod, dizideki satırlarla aynı miktarda satır siler ancak yalnızca ilk 11 satırı siler. VBA’ya oldukça yeni ve neden bunu yaptığını tam olarak anlayamıyorum. Aşağıda kullandığım komut dosyasının bir kopyası.

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 

kimse çok, eğer doğru komut dosyası değişmiş değil, ya da bir şey eksik appreicated olacağını bana bu konuda yardımcı olabilir misiniz?

Answer 1

Bu sitedeki neredeyse bilgelik kazanmış gibi görünmektedir ki, satırları silme görevi en iyi şekilde bir Range alttan üste doğru döngü yaparak ve ölçütler karşılandığında her satırı siler. Yine de bu gerçekten oldukça verimsiz bir yöntem. örneğin, bu iki parçacıkları karşılaştırın: satırla

Row: şu şekildedir:

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" 

Çıktı olan 2876,18174935641 ms

Aralık: 15,2153416146466 msn

Bu sonuçlar değiller

' muhtemelen bir Worksheet ile bireysel etkileşimlerin sayısı arttıkça, daha yavaş p rogramme olacak.

Ayırıcıların çoğaltılmasıyla ilgili bazı yayınların, aşırı sayfa etkileşimlerini önlemek için Worksheet değerlerini ve başvuru öğelerini dizilere okumaları çok uzun sürüyor. Ve yine de bu verimlilik kazançları verimsiz satır silme işlemine kaybolacak. Yanıltıcı olan, bu mesajların bazen "hızlı" olduğunu iddia etmesidir.

Bazıları, satır silme işlemleri arasında Worksheet'daki görevleri gerçekleştirmek istediklerini iddia edebilir. Ancak, VBA aralıkları adreslerini Excel formül aralığının yaptığı gibi güncelleştirir.

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 

Çıktı geçerli::

Adres silinmeden önce: silindikten sonra $ A $ 3

Adres: $ A $ 2

bu bir örnek için aşağıdaki kodu göz at

Aşağıdaki kod, "A4" ve "A6" hücrelerini ve "A8" ve "A10" orijinal hücrelerini silebilir, örneğin:

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 

Pratik bir uygulama için, OP gerçekten 'iki hızlı sayfa arasındaki çiftleri nasıl hızlıca silerim?' Sorusunu gerçekten yanıtlayabilir miydi? Aşağıdaki kod ile:

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 

Aslında, orada da OP'ın kodunda değişkenlerin rolü ve işlevi hakkında bazı yanlış anlamalar vardır ve diğer katılımcılar zaten bu dikkat çekmişlerdir. Ancak, tamlığı yararına aşağıda gibi onun/onu iki Worksheets olabilir bir şey için doğru bir okuma rutin:

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

Bu kapalı görünüyor: Ben amaçladığınız ne ve hata atmak gerektiğini sanmıyorum

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

: En verilen değerlerle

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

o çevirir.