Bevat kolom zelfde waarde dan kolom samenvoegen

[Tweety1]

Ben opzoek naar vba die een aantal cellen samenvoegt
In kolom J komen een aantal cellen voor die het zelfde waarde hebben. (tussen de kopregels)
In dien deze het zelfde is dan de tekst van de kolom “A”, “B”, “C”, “E” in de zelfde kolom samenvoegen en ontdubbelen. en van kolom "I" de inhoud van de cellen optelt.


Voorbeeld

Bekijk bijlage SamenvoegenCel.xlsx

mvg
Kasper

 

[Leotaxi]

mogelijke oplossing


mvg
Leo

 

[Tweety1]

Ziet er goed uit. :thumb: Is het alleen nog mogelijk om te kijken voordat de wordt samengevoegd of de waarde al bestaat/eerder toegevoegd is aan de cel? Zo ja dan niet toevoegen.
(Betrekking op kolom B,C en E)
bv
Nu staat onder Studiedeel-ID: "202651-202651" Dit zou ik dan graag als "202651"willen zien

 

[Leotaxi]

Dan ziet het er zo uit Kasper



mvg
Leo

 

[Tweety1]

Thanks

:thumb:

 

[Tweety1]

Ik heb de macro in een groter bestand gedraaid. Alles gaat goed op een paar puntjes na
Is het ook nog mogelijk om de lege cellen over te slaan?
Er komen ook nog een aantal waardes dubbel in de samengevoegde cellen. Is het mogelijk om deze eruit te halen? Heb deze geel aangeven in het voorbeeld bestand.
Alvast bedankt voor je hulp

Voorbeeld
Bekijk bijlage SamenvoegenCel L2-K.xlsm

 

[Leotaxi]

aangepast

Sub test()
Dim dic As Object, wks As Worksheet, t As Integer
Set dic = CreateObject("scripting.dictionary")
Application.ScreenUpdating = False
For x = 1 To Sheets.Count
    If Sheets(x).Name = "Result" Then
        Application.DisplayAlerts = False
        Sheets(x).Delete
        Application.DisplayAlerts = True
        Exit For
    End If
Next
Sheets("VoorVBA").Copy After:=Sheets(Sheets.Count): Sheets(Sheets.Count).Name = "Result"
Set wks = Sheets("Result")
With wks
    For x = 2 To .Range("J" & Rows.Count).End(xlUp).Row
        If .Range("J" & x) <> "Faciliteit-ID" And Range("J" & x) <> vbNullString Then
            .Range("K" & x) = .Range("J" & x) & "-" & Application.CountIf(.Range("J1", "J" & x), "Faciliteit-ID")
        End If
    Next
    For nrow = 2 To .Cells(Rows.Count, "K").End(xlUp).Row
        If Not IsEmpty(.Cells(nrow, "K")) Then
            If (Not dic.exists(.Cells(nrow, "K").Value)) Then
                dic.Add .Cells(nrow, "K").Value, .Cells(nrow, "K").Value
            End If
        End If
    Next
    arr = dic.keys
    lr = .Range("K" & Rows.Count).End(xlUp).Row
    For i = 0 To UBound(arr) - 1
        For Each cl In .Range("K2", "K" & lr)
            If cl = arr(i) Then
                j = j + 1
                If j = 1 Then myrow = cl.Row
                If j > 1 Then
                    .Range("A" & myrow) = .Range("A" & myrow) & "-" & .Range("A" & cl.Row)
                    If InStr(1, .Range("B" & myrow), .Range("B" & cl.Row)) = 0 Then .Range("B" & myrow) = .Range("B" & myrow) & "-" & .Range("B" & cl.Row)
                    If InStr(1, .Range("C" & myrow), .Range("C" & cl.Row)) = 0 Then .Range("C" & myrow) = .Range("C" & myrow) & "-" & .Range("C" & cl.Row)
                    If InStr(1, .Range("E" & myrow), .Range("E" & cl.Row)) = 0 Then .Range("E" & myrow) = .Range("E" & myrow) & "-" & .Range("E" & cl.Row)
                    .Range("I" & myrow) = .Range("I" & myrow) + .Range("I" & cl.Row)
                    .Range("I" & cl.Row).Resize(, 3).ClearContents
                End If
            End If
        Next
        j = 0
    Next
    .Columns.AutoFit
    .Range("K:K").ClearContents
    .Columns("J").SpecialCells(4).EntireRow.Delete
End With
Application.Goto Range("A1"), scroll:=True
End Sub

mvg
Leo

 

[Tweety1]

Thanks
Ziet er goed uit alleen denk ik dat het verkeerd heb uitgelegd.
De lege cellen dienen wel te blijven staan maar niet samengevoegd.

 

[Leotaxi]

in code vervang J door I

 .Columns("[COLOR="#FF0000"]J[/COLOR]").SpecialCells(4).EntireRow.Delete

mvg
Leo

 

[Tweety1]

Thanks :thumb: