Dubbels in blad 1 wissen.

[gast0660]

Beste helpers,
Ik ben op zoek naar een stukje code die twee werkbladen vergelijkt en de dubbels verwijdert.
Het probleem is de dubbels staan niet altijd in dezelfde rijen en daar vind ik niet direct een oplossing voor.
In het voorbeeld zou alleen rij 2 in blad 1 mogen over blijven.

 

[SjonR]

Hallo Philiep,

Wil je deze eens proberen?

Sub SjonR()
For j = 1 To Blad2.Cells(Rows.Count, 1).End(xlUp).Row
    For i = 1 To Blad1.Cells(Rows.Count, 1).End(xlUp).Row
        If Blad1.Cells(i, 1).Value = Blad2.Cells(j, 1).Value Then
            If Blad1.Cells(i, 2).Value = Blad2.Cells(j, 2).Value Then
                Blad1.Cells(i, 1).EntireRow.Delete
            End If
        End If
    Next
Next
End Sub

 

[edmoor]

Bij het verwijderen van regels moet je altijd van beneden naar boven werken en niet andersom.

 

[SjonR]

zo dan?

Sub SjonR()
For j = 1 To Blad2.Cells(Rows.Count, 1).End(xlUp).Row
    For i = Blad1.Cells(Rows.Count, 1).End(xlUp).Row To 1 Step -1
        If Blad1.Cells(i, 1).Value = Blad2.Cells(j, 1).Value Then
            If Blad1.Cells(i, 2).Value = Blad2.Cells(j, 2).Value Then
                Blad1.Cells(i, 1).EntireRow.Delete
            End If
        End If
    Next
Next
End Sub

 

[gast0660]

Hoi SjonR en Ed,
alvast bedankt voor het meedenken, ik was misschien niet duidelijk genoeg.
Ik had ook al in die richting zitten prullen, maar de gegevens in het echte bestand gaat het door tot kolomn U, worden dan wel heel wat regels, ik hoop dat het korter kan, maar ik struikel erover.

 

[SjonR]

En alle waarden per rij samenvoegen en dan vergelijken?

 

[VenA]

Best veel lusjes maar werkt wel.

Sub VenA()
Dim r As Range
  ar = Sheets("Blad1").Cells(1).CurrentRegion.Resize(, 22)
  ar1 = Sheets("Blad2").Cells(1).CurrentRegion.Resize(, 22)
  For j = 1 To UBound(ar)
    For jj = 1 To 21
      ar(j, 22) = ar(j, 22) & ar(j, jj) & "|"
    Next jj
  Next j
  For j = 1 To UBound(ar1)
    For jj = 1 To 21
      ar1(j, 22) = ar1(j, 22) & ar1(j, jj) & "|"
    Next jj
  Next j
  For j = 1 To UBound(ar)
    For jj = 1 To UBound(ar1)
      If ar(j, 22) = ar1(jj, 22) Then
        If r Is Nothing Then Set r = Sheets("Blad1").Cells(j, 1) Else Set r = Union(r, Sheets("Blad1").Cells(j, 1))
        Exit For
      End If
    Next jj
  Next j
  If Not r Is Nothing Then r.EntireRow.Interior.Color = vbYellow
End Sub

 

[SjonR]

Minder lusjes, maar geen array's

Sub SjonR()
For j = 1 To Blad2.Cells(Rows.Count, 1).End(xlUp).Row
    For i = Blad1.Cells(Rows.Count, 1).End(xlUp).Row To 1 Step -1
        For ii = 1 To 21
            check1 = check1 & Blad1.Cells(i, ii)
            check2 = check2 & Blad2.Cells(j, ii)
        Next
        If check1 = check2 Then
            Rows(i).Delete
        End If
        check1 = ""
        check2 = ""
    Next
Next
End Sub

 

[snb]

Lang leve de dictionary:

Sub M_snb()
  sn = Sheet1.Cells(1).CurrentRegion
  sp = Sheet2.Cells(1).CurrentRegion
   
  With CreateObject("scripting.dictionary")
    For j = 1 To UBound(sn)
      .Item(Join(Application.Index(sn, j), "")) = Application.Index(sn, j, 0)
    Next
    For j = 1 To UBound(sp)
      .Item(Join(Application.Index(sp, j), "")) = Application.Index(sp, j, 0)
    Next
    Sheet1.Cells(30, 1).Resize(.Count, UBound(sn, 2)) = Application.Index(.items, 0, 0)
  End With
End Sub

 

[gast0660]

Hartelijk dank iedereen.
Het probleem is opgelost.

 

[snb]

Zoals jij iedere TS vraagt: hoe dan ?

 

[HSV]

Als ik het zo lees, zou ik het zo doen.

Sub M_snb_hsv()
  sn = Blad1.Cells(1).CurrentRegion
  sp = Blad2.Cells(1).CurrentRegion
   
  With CreateObject("scripting.dictionary")
    For j = 1 To UBound(sn)
      .Item(Join(Application.Index(sn, j), "")) = Application.Index(sn, j, 0)
    Next
    For j = 1 To UBound(sp)
      If InStr(Join(.keys), Join(Application.Index(sp, j), "")) > 0 Then
       .Remove Join(Application.Index(sp, j), "")
      End If
    Next
    Blad1.Cells(30, 1).Resize(.Count, UBound(sn, 2)) = Application.Index(.Items, 0, 0)
  End With
End Sub

 

[snb]

@HSV

Tjsa, laat @dotchie nu maar eens zijn vraag duidelijk booleaans formuleren

 

[HSV]

Sommige vragen zijn al een puzzel op zich.

 

[SjonR]

Philiep, wat is uw antwoord?

 

[gast0660]

Hoi,
Gelukkig dat ik toevallig zag dat er een berichtje van Helpmij was. Sinds een paar maanden verdwijnen de mails van Helpmij in de spanfolder,ik heb er zelfs eens een vraag over gesteld op Helpmij, maar niets blijkt te werken.
Als ik niets verwacht van Helpmij kijk ik ook niet in mijn spam folder.
Maar goed ik heb de oplossing van sjonR gekozen.
Waarom, die was kort en deed wat ik wilde.
De Code van Vena en snb deden het ook, hoewel de code van snb niet direct beantwoorde aan mijn vraag. (resultaat vanaf regel 30?)
de code van HSV had ik zelfs nog niet gezien.

 

[HSV]

Je hebt het zeker niet goed getest.

Die van @snb geeft een ander uitkomst dan die van @SjonR en mij.
Daarbij opgemerkt dat mijn code (aangepaste versie van @snb) driekwart sneller is dan die van @SjonR.

Dat ze op rij 30 komen is ter illustratie natuurlijk.

Hier maar voor je veranderd als je alleen maar codes van zolder haalt en zelf niet kunt aanpassen.

Sub M_snb_hsv()
  sn = Blad1.Cells(1).CurrentRegion
  sp = Blad2.Cells(1).CurrentRegion
   
  With CreateObject("scripting.dictionary")
    For j = 1 To UBound(sn)
      .Item(Join(Application.Index(sn, j), "")) = Application.Index(sn, j, 0)
    Next
    For j = 1 To UBound(sp)
      If InStr(Join(.keys), Join(Application.Index(sp, j), "")) > 0 Then
       .Remove Join(Application.Index(sp, j), "")
      End If
    Next
    Blad1.Cells(1).CurrentRegion.ClearContents
    Blad1.Cells(1).Resize(.Count, UBound(sn, 2)) = Application.Index(.Items, 0, 0)
  End With
End Sub

 

[snb]

Heb je er al eens aan gedacht om je eigen spamfilter te wijzigen/ aan te passen ?

Je reaktie: 'komt in regel 30 terecht en is dus niet wat ik wil' vind ik onbegrijpelijk.