View Full Version : [SOLVED:] join an merge cells in column A but at same time the same rows in columns B and C
acraens
10-11-2016, 06:19 AM
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
You'd better post your question in a forum that supports your native tongue: helpmij.nl
acraens
10-11-2016, 07:03 AM
I do speak english at home. My wife is Canadian
acraens
10-11-2016, 10:36 AM
.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
10-11-2016, 12:21 PM
adding the desired output into a blank range or worksheet will help us understand your requirement.
acraens
10-11-2016, 01:58 PM
Never thought of doing that. Thanks for the advice, mancubus
Attached is the example with the desired output
mancubus
10-12-2016, 12:25 AM
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
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
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
10-12-2016, 06:10 AM
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
10-12-2016, 06:39 AM
snb,
How do I declare sp, sn, j and jj
You don't have to: remove 'option explicit'.
acraens
10-12-2016, 07:19 AM
snb
er verandert niets
Kijk eens in kolom L, M en N
acraens
10-12-2016, 08:02 AM
snb
Inderdaad daar is de oplossing die ik voor ogen had
Hartelijk bedankt
mancubus
10-12-2016, 11:38 PM
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
10-13-2016, 12:01 AM
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
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
10-13-2016, 01:15 AM
correction:
change
RowNums(UB1) = LR
to
RowNums(UB1) = LR + 1
in post #8 to include the last row value in column C
acraens
10-13-2016, 01:24 AM
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
Powered by vBulletin® Version 4.2.5 Copyright © 2024 vBulletin Solutions Inc. All rights reserved.