join an merge cells in column A but at same time the same rows in columns B and C

[acraens]

I started with follow code but i cannot change it so it would join and merge the two other columns.
If you have any ideas, please pass them on.

Sub JoinMerge()
Dim arr()
Dim LR As Long, ct As Long, t As Long
Dim Rng As Range, c As Range
Application.ScreenUpdating = False
LR = Range("A" & Rows.Count).End(xlUp).Row
ct = 1
Set Rng = Range("A2:A" & LR)
For Each c In Rng
    If c.Value <> "" Then
        ReDim Preserve arr(ct)
            arr(ct) = c.Row
        ct = ct + 1
    End If
Next c
For t = 1 To UBound(arr) - 1
With Range(Cells(arr(t), "A"), Cells(arr(t + 1) - 1, "A"))
    .Merge
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlCenter
End With
Next t
With Range(Cells(arr(t), "A"), Cells(LR, "A"))
    .Merge
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlCenter
End With
Application.ScreenUpdating = True
End Sub 

[snb]

You'd better post your question in a forum that supports your native tongue: helpmij.nl

[acraens]

I do speak english at home. My wife is Canadian

[mana]

.Resize(, 3)

[acraens]

.Resize(, 3)

I've tried to incorperate your proposal but didn't get the result i would like
Therefor did i attached my test file so you can see what the data I'm working with

[mancubus]

adding the desired output into a blank range or worksheet will help us understand your requirement.

[acraens]

Never thought of doing that. Thanks for the advice, mancubus
Attached is the example with the desired output

[mancubus]

instead of merging cells, i prefer merging cells' contents.

Sub vbax_57403_join_merge_cells_in_3_cols()

    Dim NewTbl, RowNums
    Dim LR As Long, i As Long
    Dim JoinRange As Range, cll As Range

    With Application
        .DisplayAlerts = False
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    
    Worksheets("Sheet1").Copy after:=Sheets(Sheets.Count) 'working with a backup sheet
    With ActiveSheet
        LR = .Range("C" & .Rows.Count).End(xlUp).Row
        .Range("$A$1:$C$" & LR).AutoFilter Field:=3, Criteria1:="="
        .Range("$A$1:$C$" & LR).AutoFilter Field:=1, Criteria1:="="
        .Range("$A$1:$C$" & LR).Offset(1).SpecialCells(12).EntireRow.Delete 'delete blank rows based on Cols C and A
        .AutoFilterMode = False
        
        LR = .Range("C" & .Rows.Count).End(xlUp).Row
        UB1 = .Columns(1).SpecialCells(xlCellTypeConstants, 23).Count + 1
        
        ReDim RowNums(1 To UB1)
        For Each cll In .Columns(1).SpecialCells(xlCellTypeConstants, 23)
            i = i + 1
            RowNums(i) = cll.Row
        Next
        RowNums(UB1) = LR
        
        ReDim NewTbl(1 To UBound(RowNums) - 1, 1 To 3)
        For i = 1 To UBound(RowNums) - 1
            If RowNums(i + 1) - RowNums(i) = 1 Then
                NewTbl(i, 1) = .Range("A" & i)
                NewTbl(i, 2) = .Range("B" & i)
                NewTbl(i, 3) = .Range("C" & i)
            Else
                Set JoinRange = .Range("A" & RowNums(i) & ":A" & RowNums(i + 1) - 1)
                NewTbl(i, 1) = Join(Application.Transpose(JoinRange.Value), Chr(10))
                Set JoinRange = .Range("B" & RowNums(i) & ":B" & RowNums(i + 1) - 1)
                NewTbl(i, 2) = Join(Application.Transpose(JoinRange.Value), Chr(10))
                Set JoinRange = .Range("C" & RowNums(i) & ":C" & RowNums(i + 1) - 1)
                NewTbl(i, 3) = Join(Application.Transpose(JoinRange.Value), Chr(10))
            End If
        Next i
        
        .Cells.Clear
        .Cells(1).Resize(UBound(NewTbl, 1), UBound(NewTbl, 2)) = NewTbl
    End With

    With Application
        .EnableEvents = True
    End With

End Sub

[mana]

function for only you

Option Explicit

Function MergeSpecial(rr As Range)
    Dim s As String
    Dim r As Range
    
    For Each r In rr
        s = s & vbLf & r.Value
    Next
    rr.Value = Empty
    rr.Merge
    rr.Value = Mid(s, 2)

End Function

then, insert the function in your original code.

With Range(Cells(arr(t), "A"), Cells(arr(t + 1) - 1, "A"))
    Call MergeSpecial(.Offset(, 1))
    Call MergeSpecial(.Offset(, 2))
    .Merge

[snb]

Hou het simpel:

Sub M_snb()
   [a1:C36].Replace vbLf, ""
   [a1:C36].Replace vbCr, ""
   
   sn = [a1:C36]
   ReDim sp(1 To Columns(1).SpecialCells(2).Count, 1 To 3)
   
   For j = 1 To UBound(sn)
      If sn(j, 1) <> "" Then jj = jj + 1
      If sn(j, 1) <> "" Then sp(jj, 1) = sn(j, 1)
      If sn(j, 2) <> "" Then sp(jj, 2) = sp(jj, 2) & IIf(sp(jj, 2) = "", "", vbLf) & sn(j, 2)
      If sn(j, 3) <> "" Then sp(jj, 3) = sp(jj, 3) & IIf(sp(jj, 3) = "", "", vbLf) & sn(j, 3)
   Next

   Cells(1, 12).Resize(UBound(sp), UBound(sp, 2)) = sp
End Sub

[acraens]

Mancubus,
the code does the work with a low amount of letters in the cells but when there's a lot of letters, the code gives "Run-time error '13': Type mismatch"
Is there a solutions for this error?

[acraens]

snb,

How do I declare sp, sn, j and jj

[snb]

You don't have to: remove 'option explicit'.

[acraens]

snb
er verandert niets

[snb]

Kijk eens in kolom L, M en N

[acraens]

snb
Inderdaad daar is de oplossing die ik voor ogen had

Hartelijk bedankt

[mancubus]

Mancubus,
the code does the work with a low amount of letters in the cells but when there's a lot of letters, the code gives "Run-time error '13': Type mismatch"
Is there a solutions for this error?

just not to leave the question unreplied:
https://msdn.microsoft.com/en-us/lib.../gg251467.aspx

A variable-length string can contain up to approximately 2 billion (2^31) characters.
A fixed-length string can contain 1 to approximately 64K (2^16) characters.

[acraens]

mancubus,
thanks for the explanation.
I'll keep looking what the problem is in the data I'm trying to manipulate.

Thank you for all your help

[snb]

I'd prefer:

Sub M_snb()
    [a1:C36].Replace vbLf, ""
    [a1:C36].Replace vbCr, ""
     
    sn = [a1:C36]
    ReDim sp(1 To Columns(1).SpecialCells(2).Count, 1 To 3)
     
    For j = 1 To UBound(sn)
        If sn(j, 1) <> "" Then y = y + 1
        For jj = 1 To 3
            sp(y, jj) = sp(y, jj) & IIf(sp(y, jj) = "" Or sn(j, jj) = "", "", vbLf) & sn(j, jj)
        Next
    Next
     
    Cells(1, 12).Resize(UBound(sp), UBound(sp, 2)) = sp
End Sub

[mancubus]

correction:

change

        RowNums(UB1) = LR

to

        RowNums(UB1) = LR + 1

in post #8 to include the last row value in column C