Samenvoegen tekst uit 4 kolommen voor range te kunnen bepalen

tonissteiner

Gebruiker
Lid geworden
17 sep 2008
Berichten
342
Hallo,

ik kan via onderstaande code duplicaten vinden in een bereik. Echter kijkt deze code maar naar de waarde uit een kolom. Ik heb nu een toepassing waarbij een nummer bestaat uit de waarden uit de combinatie uit vier kolommen naast elkaar.

Als ik de formule aanpas naar het bereik C4:F4 bekijkt de macro nog steeds elke cel afzonderlijk ipv de combinatie.

Graag hulp hoe ik de code kan aanpassen zodat gekeken wordt naar het samenvoegen van de vier cellen naast elkaar.
C4 & D4 & E4 & F4 werkt ook niet.

Alvast bedankt.

Code:
Sub FindDuplicatesInColumnTest()

    Dim r As Range, c As Range, s As String
    Set r = Range("C4:E4", Range("C" & Rows.Count).End(xlUp))

    For Each c In r
        If WorksheetFunction.CountIf(r, c) > 1 Then
            With c.Characters.Font
                .Bold = True
                .Size = 12
                .Color = vbMagenta
            End With

        If InStr(1, s, c) = 0 Then s = s & vbCr & c

        End If

    Next

    If (s = "") Then
            With r.Characters.Font
                .Bold = False
                .Size = 9
                .Color = vbBlack
            End With
    End If

    MsgBox IIf(s <> "", "Volgende duplicaten werden gevonden:" & vbLf & s, "Geen duplicaten gevonden!"), vbInformation, "Duplicaten"

End Sub
 
Je zou een hulpkolom kunnen gebruiken waarin je C&D&E&F plaatst.
Of zo misschien:
Code:
Sub Duplikaten()
    Dim Dict
    Dim r As Long
    Set Dict = CreateObject("Scripting.Dictionary")
    For r = 4 To Cells(Rows.Count, 3).End(xlUp).Row
        tekst = Cells(r, 3) & Cells(r, 4) & Cells(r, 5) & Cells(r, 6)
        If Not Dict.exists(tekst) Then
            Dict.Add tekst, r
        Else
            Debug.Print "Rij " & r; " is een duplicaat."
        End If
    Next
End Sub
 
Hallo, dank voor je hulp en code. Hulpkolom was ook al in me opgekomen echter wou het eerst proberen in een code. Spaart me misschien wat tijd om de hele layout niet te moeten aanpassen.

Ik moet me even verdiepen in je code en wat aanpassen voor mezelf want ze werkt nog niet 100% zoals ik ze wil (op het scherm zichtbaar maken in vette tekst en andere kleur welke de duplicaten zijn. Als ik de code run zegt ie dat er pas vanaf rij 52 een duplicaat is en dat is in mijn werkblad een lege rij ;o))
 
@AHulpje:

Vermijd overbodige interaktie met een werkblad: gebruik arrays
Gebruik ingebouwde Exceleigenschappen zoals currentregion

CSS:
Sub M_snb()
    sn=cells(1).currentregion

    With creatobject("scripting.dictionary")
       for j=4 to ubound(sn)
          c00=sn(j,3)&sn(j,4)&sn(j,5)&sn(j,6)
          if .exists(c00) then msgbox "dubbel"
          x0=.item(c00)
      next
    end with
End Sub
 
@snb
Ik weet dat het gebruik van array's een van jouw stokpaardjes is.;)
Maar jouw oplossing kan zomaar fout gaan, wat als rij 1 leeg is?
Zonder voorbeelddocument vond ik het daarom veiliger niet van currentregion gebruik te maken.
P.S.
Er ontbreekt een e in creatobject.
En verder wordt niet weergegeven welke rij een duplicaat bevat.
 
.Item(c00) = Empty of .Item(c00) = 1

ipv (onnodige variable)

x0=.item(c00)
 
Als je alle overbodige lege rijen uit je tabel verwijdert doet mijn oplossing het prima.
 
Voor honderd rijen speelt het misschien geen rol maar voor grotere bereiken is interactie met het werkblad werkelijk uit den boze. De verwerkingstijd vergroot exponentieel aan het aantal rijen.
Dus daarom toch een zeer groot pleidooi om je het werken met Arrays eigen te maken.
Daarom een aanpassing van de code van snb die echt wel de te volgen weg weergeeft.

Code:
Sub M_snb()
    sn = Blad004.Range("C4", Range("C" & Rows.Count).End(xlUp)).Resize(, 4)

    With CreateObject("scripting.dictionary")
        For j = 1 To UBound(sn)
            c00 = sn(j, 1) & sn(j, 2) & sn(j, 3) & sn(j, 4)
            If Not .exists(c00) Then
                .Item(c00) = "Rij " & j + 3
            Else
                .Item(c00) = .Item(c00) & " en Rij " & j + 3
            End If
        Next
        For Each it In .items
            If InStr(1, it, "en") Then s = s & vbCr & it
        Next
    End With
    MsgBox IIf(s <> "", "Volgende duplicaten werden gevonden:" & vbLf & s, "Geen duplicaten gevonden!"), vbInformation, "Duplicaten"
End Sub

En zoals @AHulpje aangeeft is het verwijderen van lege rijen in een tabel ook wel een must, anders ga je compleet voorbij aan de doelstelling van een tabel.
 
Als je alle overbodige lege rijen uit je tabel verwijdert doet mijn oplossing het prima.
Goede morgen AHulpje, idd je code werkt prima zonder lege rijen. Even zoeken hoe ik dit nu best verwerk in mijn document. Bedankt voor de hulp
 
Wil je echt in de geest van tabellen blijven gebruik je onderstaande om het bereik te definiëren.
Code:
Sub M_snb()
    sn = Blad004.ListObjects(1).DataBodyRange.Columns("C:F")
    With CreateObject("scripting.dictionary")
        For j = 1 To UBound(sn)
            c00 = sn(j, 1) & sn(j, 2) & sn(j, 3) & sn(j, 4)
            If Not .exists(c00) Then
                .Item(c00) = "Rij " & j + 3
            Else
                .Item(c00) = .Item(c00) & " en Rij " & j + 3
            End If
        Next
        For Each it In .items
            If InStr(1, it, "en") Then s = s & vbCr & it
        Next
    End With
    MsgBox IIf(s <> "", "Volgende duplicaten werden gevonden:" & vbLf & s, "Geen duplicaten gevonden!"), vbInformation, "Duplicaten"
End Sub
 
Dag Rudi, bedankt voor de aanpassing van de code van snb. Tabel aangepast en werkt idd ook prima. Daar kan ik misschien ook wat mee.
 
@AHulpje
Er zullen altijd mensen zijn die moeilijk kunnen toegeven dat andere oplossingen beter zijn en elke strohalm grijpen om toch maar hun ongelijk niet te moeten toegeven. So be it.
In dit geval zal het verschil inderdaad minder zichtbaar zijn omdat dit een simpel geval is.
Ik heb al geweten van codes zoals de jouwe (loopen van cel per cel) herleid werden van minuten naar enkele seconden in meer complexe gevallen.
Waar praten we dan over?
Bottomline is dat het een goede gewoonte is die je je eigen moet maken bij het programmeren. Zeker als je startende VBA'er bent.
 
@Warme bakkertje
Ik beweer nergens dat je nooit array's moet gebruiken, en ook niet dat de oplossing van snb niet beter is. Ik gebruik zelf regelmatig array's, maar ik bekijk het van geval tot geval. In het algemeen wordt de code iets minder leesbaar als je array's gebruikt en is dat ook voor beginnende VBA'ers lastiger.
Je toevoeging van het gebruik van Listobjects is overigens prima.
 
Het verschil in snelheid is sterk afhankelijk van het aantal berekeningen dat wordt uitgevoerd bij iedere wijziging in een werkblad (voorwaardelijke opmaak, benoemde gebieden, UDF's) etc.
Om daarvan niet afhankelijk te zijn gebruik je in VBA zoveel mogelijk het werkgeheugen.
De VBA elementen usedrange en currentregion gaan uit van een correct opgezet werkblad. Als kolom 1 of rij 1 leeg is, dient eerst de struktuur van het werkblad verbeterd te worden. Aanpassing van VBA aan een onjuiste opbouw houdt die struktuurslordigheid in stand.
Iedere VBA gebruiker (beginneling of gevorderd) leert het meest van code die uitgaat van een correcte gegevensstruktuur. (zoals bijv. in een listobject).
 
Code:
=LET(t;DROP(GROUPBY(C4:C9&D4:D9&E4:E9;ROW(C4:C9);ARRAYTOTEXT;;0);;1);FILTER(t;ISNUMBER(SEARCH(";";t))))

Zelfde output als de vba code. Geeft dus de regelnummers als output
 
Terug
Bovenaan Onderaan