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/library/office/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

[acraens]

snb
I do agree with you that your solution is shorter and to the point
I do like to learn more vba from the other codes