Rijen met dubbel en unieke waarden samenvoegen

[Henk5915]

Hoi, wie zou mij kunnen helpen? Ik heb een Excelbestand met daarin rijen met zowel dubbele als unieke waarden:

Bekijk bijlage Voorbeeldmap.xlsx

Deze zie rijen zie je in rij 2 t/m rij 14. De dubbele waarden zijn rood gekleurd. Wat ik als output zou willen zie je in rij 17 t/m 25.


Is er een snelle manier om dat te doen?


Alvast super bedankt!!!!

 

[keb]

zie https://support.office.com/nl-nl/ar...ijderen-ccf664b0-81d6-449b-bbe1-8daaec1e83c2?

In het kort beschreven:
- kopieer de hele range naar cel A20
- Selecteer de gekopieerde range, via Gegevens, Hulpmiddelen voor gegevens, Duplicaten verwijderen, vink alleen de Naam aan, OK

Zie voorbeeld

Sub Filteren()

' Filtert unieke waarden en plaatst de matrix in cel A20

    Range("A1:E14").Select
    Selection.Copy
    
    Range("A20").Select
    ActiveSheet.Paste

    Range("A20:E33").Select
    Application.CutCopyMode = False
    ActiveSheet.Range("$A$20:$E$33").RemoveDuplicates Columns:=4, Header:=xlYes
End Sub

 

[Henk5915]

Probleem is volgens mij dan dat ik wel de dubbele waarden verwijderd heb maar daarmee ook de unieke waarde die in de rij van de dubbele waarde stond die verwijderd is en die niet in de rij staat van de dubbele waarde die niet verwijderd is.

 

[cow18]

Sub JeGegevens()
    sn = Sheets("blad1").Range("A1").CurrentRegion
    With CreateObject("Scripting.Dictionary")
        .comparemode = 1
        For i = 1 To UBound(sn)
            If Not .exists(sn(i, 4)) Then                            'naam staat nog niet in dictionary
                 .Add sn(i, 4), Application.Index(sn, i, 0)                                     'toevoegen aan dictionary
            Else
                sp = .Item(sn(i, 4))                                 'array met reeds aanwezige gegevens
                For j = 1 To 5
                    If Len(sn(i, j)) Then sp(j) = sn(i, j)    'nieuwe gegevens toevoegen
                Next
                .Item(sn(i, 4)) = sp                                 'array terugzetten in dictionary
            End If
        Next
        Cells(31, 1).Resize(.Count, 5) = Application.Index(.items, 0, 0)    'items wegschrijven naar werkblad
    End With
End Sub

 

[AlexCEL]

Hierbij nog een variant met enkel formules.

Let op: het betreft matrixfuncties, die moet je afsluiten met Control+Shift+Enter na invoeren/wijzigen.

 

[Henk5915]

Bedankt allemaal voor de input, kan ik mee vooruit!

 

[snb]

Sub M_snb()
   sn = Cells(1).CurrentRegion
   
   For j = 3 To UBound(sn)
       If sn(j, 4) = sn(j - 1, 4) Then
          For jj = 1 To UBound(sn, 2)
             If sn(j, jj) <> "" And sn(j - 1, jj) = "" Then sn(j - 1, jj) = sn(j, jj)
             sn(j, jj) = ""
          Next
       End If
   Next
   
   Cells(30, 1).Resize(UBound(sn), UBound(sn, 2)) = sn
   Cells(30, 4).Resize(UBound(sn)).SpecialCells(4).EntireRow.Delete
End Sub