Cellen samenvoegen

[Kaptain]

Beste wigi,

Ik heb met veel plezier jouw code gebruikt om cellen samen te voegen. Echter, als ik cellen selecteer die niet naast elkaar staan, doet hij het niet...... Dan loopt ie vast bij de volgende regel:
If WorksheetFunction.CountBlank(Selection) = Selection.Count Then

Kan jij me zeggen of het ook mogelijk is om dit wel voor elkaar te krijgen?

Dank,

Henry

 

[m@rio]

Titel van je vraag aangepast zodat bekend is wat het probleem is

 

[Wigi]

Dit is beter:

Sub cellenSamenvoegen()
'  ________________________________________
' |
' |  Wim Gielis, also on http://www.wimgielis.be
' |________________________________________

'voorafgaande noot: om de samengevoegde cellen naar het Klembord te kopiëren moet je bij
'Tools > References... (Extra > Verwijzing) een vinkje zetten bij Microsoft Forms 2.0 object library

    Dim rng As Range
    Dim lAantal As Long
    Dim rLegeCellen As Range
    Dim arrSamen() As String
    Dim sScheiding As String
    Dim sSamengevoegd As String
    Dim MyDataObj As New DataObject
    Dim sKlembordGelukt As String
    
    On Error Resume Next
    Set rLegeCellen = Selection.SpecialCells(xlCellTypeBlanks)
    On Error GoTo 0
    
    If rLegeCellen.Count = Selection.Count Then
        MsgBox "Je hebt enkel lege cellen geselecteerd. De macro stopt hier.", vbInformation, Application.UserName
    Else
        sScheiding = Application.InputBox("Geef het scheidingsteken op aub." & vbNewLine & vbNewLine & "(Je mag " _
            & "bijvoorbeeld ook , typen gevolgd door een spatie of zelfs dit vak leeglaten)", "Scheidingsteken", _
            ",", Type:=2)
        
        lAantal = 0
        
        'array inlezen
        For Each rng In Selection
            lAantal = lAantal + 1
            ReDim Preserve arrSamen(lAantal)
            arrSamen(lAantal) = rng.Text
        Next
        
        'de tekst samenvoegen
        sSamengevoegd = Join(arrSamen, sScheiding)
        
        'het scheidingsteken aan het begin niet meenemen
        sSamengevoegd = Right(sSamengevoegd, Len(sSamengevoegd) - Len(sScheiding))
        
        'de samengevoegde tekst naar het Immediate Window overbrengen
        Debug.Print sSamengevoegd & vbNewLine
        
        'de samengevoegde tekst naar het Klembord overbrengen
        On Error GoTo 0
        MyDataObj.SetText sSamengevoegd
        MyDataObj.PutInClipboard
        
        If Err.Number = 0 Then sKlembordGelukt = " en ook op het Klembord"
        On Error GoTo 0
        
        MsgBox lAantal & " cellen werden samengevoegd" & vbNewLine & vbNewLine & "De inhoud van de samengevoegde " _
            & "cellen staat nu in het Immediate Window in VBE" & sKlembordGelukt, vbInformation, Application.UserName
    End If
End Sub

Ik heb het aangepast en op de site gezet.

Wigi