verwijderen van dubbele data in een tabel

[Andre175]

Met onderstaande code wordt een tabel gemaakt met data uit meerdere sheets.
Het leek me juist te werken, maar kwam er achter dat er toch een kleine fout in zat.

bij het verwijderen van dubbele data gaat er iets mis (rode gedeelte in code)
Mijn bedoeling was dat wanneer de gegevens in A,B en E in meerdere regels gelijk zijn, dan de dubbele data te verwijderen.
kolom A = voornaam
Kolom B = Achternaam
Kolom E = mailadres

dus als bijvoorbeeld
A1 = Daan
B1 = Jansen
E1 = jansen@iets.nl

A12 = Daan
B12 = Jansen
E12 = jansen@iets.nl

dan moet 1 van de regels verwijderd worden.

Ik kwam tot de ontdekking dat er per kolom gekeken wordt met de code die ik gebruik.
Als de voornaam 2 x voorkomt, terwijl de achternaam anders is, wordt er al een regel verwijderd.
Dit is niet de bedoeling.

    On Error Resume Next
    With Sheets("Kids")
       .Cells(1).Select
       .ListObjects.Add , , , 1, .Cells(1).CurrentRegion
    End With
    
    For Each it In Sheets
      If InStr("LadderKids", it.Name) = 0 Then
        With it.UsedRange
            Sheets("Kids").Cells(Rows.Count, 2).End(xlUp).Resize(.Rows.Count, .Columns.Count - 2) = .Offset(1, 2).Value
          End With
      End If
      Next
    
    [COLOR="#FF0000"]Sheets("Kids").ListObjects("Tbl_Kids").DataBodyRange.RemoveDuplicates Array(1, 2, 5), xlYes[/COLOR]
    
    
    Set Sh1 = Sheets("Kids")
    Set sh2 = Sheets("Ladder")
    
    
    ar1 = Sh1.Range("B2:P200")
    For i = 3 To Sheets.Count
        
        For j = 1 To Sh1.Range("A" & Rows.Count).End(xlUp).Row - 2
            For jj = 1 To Sheets(i).Range("A" & Rows.Count).End(xlUp).Row - 1
                Sh1.Cells(j + 1, 1) = j
                ar2 = Sheets(i).Range("A2:H50")
                If ar1(j, 1) = ar2(jj, 3) And ar1(j, 2) = ar2(jj, 4) And ar1(j, 5) = ar2(jj, 7) Then
'                    sh1.Cells(j + 1, i + 5).Value = Sheets("Ladder").Range("A" & i - 1)
                    Sh1.Cells(j + 1, Columns.Count).End(xlToLeft).Offset(, 1) = Sheets("Ladder").Range("A" & i - 1)
                End If
            Next jj
        Next j
    Next i

iemand een idee hoe de code wel zou moeten?

 

[Andre175]

zelf ook al ff aan het puzzelen geweest.

    Set sh1 = Sheets("Kids")
    Set Sh2 = Sheets("Ladder")
    
    For j = 1 To sh1.Range("A" & Rows.Count).End(xlUp).Row - 2
        For jj = 2 To sh1.Range("A" & Rows.Count).End(xlUp).Row - 2
            If sh1.Range("A" & j) = h1.Range("A" & jj) And sh1.Range("B" & j) = h1.Range("B" & jj) And sh1.Range("E" & j) = h1.Range("E" & jj) Then
            sh1.ListObject.ListRows(jj).Delete
            End If
        Next jj
    Next j

in plaats van

Sheets("Kids").ListObjects("Tbl_Kids").DataBodyRange.RemoveDuplicates Array(1, 2, 5), xlYes

Als alle data op dezelfde manier zou zijn ingevoerd, dan zou dit denk ik moeten werken.
Nu blijkt dat bij sommige namen dat er een spatie achter staat.
Hierdoor gaat de vergelijking de fout in.

 

[HSV]

Ik kwam tot de ontdekking dat er per kolom gekeken wordt met de code die ik gebruik.
Als de voornaam 2 x voorkomt, terwijl de achternaam anders is, wordt er al een regel verwijderd.
Dit is niet de bedoeling.

Dat lijkt me onmogelijk.

 

[Andre175]

ik denk dat je gelijk hebt Harry....
de fout zit ergens anders, waar weet ik nog niet.
was maar ff een bak koffie gaan doen.
zag het ff niet meer...:d

het originele bestand zit vol met gevoelige informatie.... zal eens zien dat ik een test bestandje erbij maak

 

[Andre175]

oke....

het is me nu wel duidelijk dat de fout niet in Sheets("Kids").ListObjects("Tbl_Kids").DataBodyRange.RemoveDuplicates Array(1, 2, 5), xlYes zit.

    Set Sh1 = Sheets("Kids")
    Set sh2 = Sheets("Ladder")

    ar1 = Sh1.Range("B2:P200")
    For i = 3 To Sheets.Count
        
        For j = 1 To Sh1.Range("A" & Rows.Count).End(xlUp).Row - 2
            For jj = 1 To Sheets(i).Range("A" & Rows.Count).End(xlUp).Row - 1
                Sh1.Cells(j + 1, 1) = j
                ar2 = Sheets(i).Range("A2:H50")
                If ar1(j, 1) = ar2(jj, 3) And ar1(j, 2) = ar2(jj, 4) And ar1(j, 5) = ar2(jj, 7) Then
                    Sh1.Cells(j + 1, Columns.Count).End(xlToLeft).Offset(, 1) = Sh2.Range("A" & i - 1)
                End If
            Next jj
        Next j
    Next i

in dit gedeelte van de code vergelijk ik per regel de voornaam, achternaam en mailadres uit de tabel met elke achterliggende sheet of deze combinatie voorkomt.
Indien ja dan moet achter de regel het ID van het evenement komen te staan.
Dit gebeurd ook wel.

Echter ik heb het vermoeden dat hoofdletters/kleine letters en spaties achter een naam invloed heeft op de vergelijking.
Sommige kinderen hebben zich voor meerdere evenementen opgegeven.
Bij het ene evenement hebben ze dan hun naam met een hoofdletter geschreven en bij het andere met een kleine letter. (Daan of daan)
Of bij de ene staat "Daan " en de andere "Daan" (met spatie/zonder spatie)

De sheets met gegevens worden van een website gedownload, om elke sheet langs te gaan of ergens een spatie achter staat is onbegonnen werk.

Is mijn gedachte goed? kunnen hoofdletters/kleine letters en wel of geen spatie achter de naam invloed hebben op de vergelijking?
zo ja, is dit te omzeilen?


dan nu ook een bestand, op tabblad "Ladder" staan alle evenementen met daarachter het aantal opgaves.
op tabblad "Kids" wordt de lijst gemaakt. Tel ik hier het aantal opgaves (ingevulde cellen in bereik A2140), dan zie ik een verschil.

 

[HSV]

Daan Of daan maakt niet uit, wel de spatie achter een naam.

Je kan de spaties verwijderen met:

With ListObjects(1)
  .DataBodyRange = Application.Trim(.DataBodyRange)
  .DataBodyRange.RemoveDuplicates Array(1, 2, 5), xlYes
End With

 

[Andre175]

Nu wordt het verschil van opgaves nog groter....

Sub LijstKids()
    Application.ScreenUpdating = False
    With Sheets("Kids")
    
        s1 = .Range("Tbl_Kids").ListObject.ListRows.Count + 1
        s2 = .Range("Tbl_Kids").ListObject.ListColumns.Count + 1
        If s1 = 1 Then GoTo slaover
        .Range("A2:AV" & s1).ClearContents
        .ListObjects("Tbl_Kids").Resize Range("$A$1:$H$2")
slaover:
    End With
'   Exit Sub
    On Error Resume Next
    With Sheets("Kids")
       .Cells(1).Select
       .ListObjects.Add , , , 1, .Cells(1).CurrentRegion
    End With
    
    For Each it In Sheets
      If InStr("LadderKids", it.Name) = 0 Then
        With it.UsedRange
            Sheets("Kids").Cells(Rows.Count, 2).End(xlUp).Resize(.Rows.Count, .Columns.Count - 2) = .Offset(1, 2).Value
          End With
      End If
      Next
      
    

    
    Set Sh1 = Sheets("Kids")
    Set Sh2 = Sheets("Ladder")
        
[COLOR="#FF0000"]    With Sh1.ListObjects("Tbl_Kids")
      .DataBodyRange = Application.Trim(.DataBodyRange)
      .DataBodyRange.RemoveDuplicates Array(2, 3, 6), xlYes
    End With[/COLOR]
    
'    Sh1.ListObjects("Tbl_Kids").DataBodyRange.RemoveDuplicates Array(2, 3, 6), xlYes
    
    ar1 = Sh1.Range("B2:P200")
    For i = 3 To Sheets.Count
        
        For j = 1 To Sh1.Range("A" & Rows.Count).End(xlUp).Row - 2
            For jj = 1 To Sheets(i).Range("A" & Rows.Count).End(xlUp).Row - 1
                Sh1.Cells(j + 1, 1) = j
                ar2 = Sheets(i).Range("A2:H50")
                If ar1(j, 1) = ar2(jj, 3) And ar1(j, 2) = ar2(jj, 4) And ar1(j, 5) = ar2(jj, 7) Then
'                    sh1.Cells(j + 1, i + 5).Value = Sheets("Ladder").Range("A" & i - 1)
                    Sh1.Cells(j + 1, Columns.Count).End(xlToLeft).Offset(, 1) = Sh2.Range("A" & i - 1)
                End If
            Next jj
        Next j
    Next i
    
    Sheets("Kids").ListObjects("Tbl_Kids").Resize Range("$A$1:P" & j)
    Application.ScreenUpdating = True
End Sub

morgen weer een dag.....

 

[HSV]

Welke namen gaan volgens jou niet goed, anders moet ik dat zelf ook nog uitpluizen.

Edit: Ik heb de lijst gesorteerd op achternaam en ik zie helemaal geen duplicaten op kolom 2 en 3.

 

[Andre175]

mmmmm.... nu heb ik wel de spaties uit de tabel op tabblad "Kids" gehaald.
Maar op alle tabbladen die van de website komen staan natuurlijk nog wel de spaties

 

[HSV]

Overbodige spaties op dezelfde manier verwijderen lijkt me voor de hand liggend.

 

[Andre175]

ik heb er nu het volgende bij tussen geplakt

    For i = 3 To Sheets.Count
    Sheets(i).Range("A1:I50") = Application.Trim(Sheets(i).Range("A1:I50"))
    Next i

dit geeft al een verbetering.

@ Harry
in #6 gaf je aan

Daan Of daan maakt niet uit, wel de spatie achter een naam.

dit bedoel je zeker voor dat het niet uitmaakt voor het verwijderen van dubbele waarden?

het zal wel uitmaken voor de vergelijking die ik maak of 2 cellen dezelfde inhoud hebben lijkt me.

ik heb ooit eens ergens een code gelezen om het verschil in hoofdletters of kleine letters te vermijden.
Dus dat "Daan" en "daan"als hetzelfde wordt gezien.

weet je daar zo een oplossing voor?

 

[HSV]

Daan en daan worden hier als dezelfde gezien.

Houd het simpel met voorbeelden.

 

[Andre175]

Toen ik deze topic startte dacht ik dat het probleem lag bij het verwijderen van dubbele waarden.

Het bleek toch ergens anders te liggen.

For i = 3 To Sheets.Count
        
        For j = 1 To Sh1.Range("A" & Rows.Count).End(xlUp).Row - 2
            For jj = 1 To Sheets(i).Range("A" & Rows.Count).End(xlUp).Row - 1
                Sh1.Cells(j + 1, 1) = j
                ar2 = Sheets(i).Range("A2:H50")
                [COLOR="#FF0000"]If ar1(j, 1) = ar2(jj, 3) And ar1(j, 2) = ar2(jj, 4) And ar1(j, 5) = ar2(jj, 7)[/COLOR] Then
                    Sh1.Cells(j + 1, Columns.Count).End(xlToLeft).Offset(, 1) = Sh2.Range("A" & i - 1)
                End If
            Next jj
        Next j
    Next i

Hier vergelijk ik de waarde uit de tabel op tabblad kids met de waarde op de gedownloade bladen van de website.
Aangezien er 20 tot 30 evenementen zijn, en dus net zoveel tabbladen, kan het voorkomen dat een kind zich voor meerdere evenementen heeft opgegeven.
Als men dus de ene keer bij de opgave "Daan" heeft ingevuld en bij een ander evenement "daan", dan klopt mijn vergelijking niet meer.

vandaar dat ik wil proberen de hoofdlettergevoeligheid in mijn vergelijking uit te schakelen.

 

[HSV]

Vergelijking in kleine letters.

 If lcase(ar1(j, 1)) = lcase(ar2(jj, 3)) And lcase(ar1(j, 2)) = lcase(ar2(jj, 4)) And lcase(ar1(j, 5)) = lcase(ar2(jj, 7)) Then