3 cellen samenvoegen d.m.v waarde in vorige cel.

[danny147]

Beste Wim

Heb geprobeerd maar helaas lukt het niet.
Ziehier de code, maar geeft steeds een fout weer.
In het vet gedrukt heb ikzelf ingevuld

Sub SamenvoegenCellen()
    Dim rng    As Range

    For Each rng In Range("D2:D20")
    
        If rng <> "" Then
        
            rng.Offset(0, 1) = rng.Offset(0, 1) & " " & rng.Offset(0, 2) & " " & rng.Offset(0, 3)
            Application.DisplayAlerts = False
            rng.Offset(0, 1).Resize(, 3).Merge
            
        [B]Else: rng ""
        
            rng.Offset(0, 1) = rng.Offset(0, 1) & " " & rng.Offset(0, 2) & " " & rng.Offset(0, 3)
            Application.DisplayAlerts = False
            rng.Offset(0, 1).Resize(, 3).UnMerge[/B]      
  
        End If
        
    Next rng
    Application.DisplayAlerts = True
    Columns("E:G").AutoFit
End Sub

En deze staat in Blad1

Private Sub Worksheet_Change(ByVal Target As Excel.Range)
    On Error Resume Next
    Application.EnableEvents = False
    If Not Intersect(Target, Columns(4)) Is Nothing Then
        Call SamenvoegenCellen
    End If
    Application.EnableEvents = True
End Sub

Groetjes Danny :thumb:

 

[Wigi]

In de Else komt niets anders.

Else

en met

rng.Offset(0, 1) = rng.Offset(0, 1) & " " & rng.Offset(0, 2) & " " & rng.Offset(0, 3)

voeg je de celinhouden van 3 cellen samen, mij lijk het dat je het omgekeerde nodig hebt.

Wigi

 

[danny147]

Beste Wim

Dit heb ik ervan gebakken.

Sub SamenvoegenCellen()
    Dim rng    As Range

    For Each rng In Range("D2:D20")

        If rng <> "" Then
            rng.Offset(0, 1) = rng.Offset(0, 1) & " " & rng.Offset(0, 2) & " " & rng.Offset(0, 3)
            Application.DisplayAlerts = False
            rng.Offset(0, 1).Resize(, 3).Merge

        Else
            rng.Offset(0, 3) = rng.Offset
            Application.DisplayAlerts = False
            rng.Offset(0, 1).Resize(, 3).UnMerge
        End If

    Next rng
    Application.DisplayAlerts = True
    Columns("E:G").AutoFit
End Sub

Het gaat in de goede richting, maar de cellen verkleinen of vergroten soms.
Kan jij het verder aanpassen.

Groetjes Danny. :thumb:

 

[Wigi]

Als je met

rng.Offset(0, 1) = rng.Offset(0, 1) & " " & rng.Offset(0, 2) & " " & rng.Offset(0, 3)

steden samenvoegt, kan je ze toch ook weer uit elkaar halen? Je zoekt op de plaats van de spatie (onder de veronderstelling dat de namen geen spaties van zichtzelf bevatten), en dan haal je de juiste stukken tekst er terug uit.

Wigi

 

[danny147]

Beste Wim

Heb dan maar het volgende geprobeerd, maar nog niet zoals het moet zijn.

Sub SamenvoegenCellen()
    Dim rng    As Range

    For Each rng In Range("D2:D20")
        If rng <> "" Then
            rng.Offset(0, 1) = rng.Offset(0, 1) & " " & rng.Offset(0, 2) & " " & rng.Offset(0, 3)
            Application.DisplayAlerts = False
            rng.Offset(0, 1).Resize(, 3).Merge
        Else
            rng.Offset(0, 1) = rng.Offset(0, 1) & rng.Offset(0, 2) & rng.Offset(0, 3)
            Application.DisplayAlerts = False
            rng.Offset(0, 1).Resize(, 3).UnMerge
        End If
    Next rng
    Application.DisplayAlerts = True
    Columns("E:G").AutoFit
End Sub

Je zal eens een handje moeten toesteken denk ik, ant ik geraak er niet aan uit.

Groetjes Danny :thumb: