merging cells and maintaining the fonts size of each cell

[Guest]

I am merging cells but lose the font styles of each of the merged cells in
the new cell
Is there a way to keep them maintained?

 

[Dave Peterson]

Are you concatenating the values in the cell using a formula?

Like: =a1&b1&c1

If yes, then formulas won't retain the styles/formats of their dependent ranges.

 

[Guest]

Can you suggest a way other than the formula below to achieve my result?

 

[Dave Peterson]

You could use a subroutine that concatenates the strings and then goes back and
fixes the font for each character.

But you have to extract each font attribute that you want (name, boldness,
color, etc).

This example takes the values in A1:A3 and concatenates them into A4. And then
just keeps track of the font.name for each character.

Option Explicit
Sub testme()

Dim myStr As String
Dim myAddr As Variant
Dim myCell As Range
Dim iCtr As Long
Dim cCtr As Long
Dim oCtr As Long

myAddr = Array("a1", "a2", "a3")

With ActiveSheet
Set myCell = .Range("a4")
myStr = ""
For iCtr = LBound(myAddr) To UBound(myAddr)
myStr = myStr & .Range(myAddr(iCtr)).Value
Next iCtr

myCell.Value = myStr

oCtr = 0
For iCtr = LBound(myAddr) To UBound(myAddr)
For cCtr = 1 To Len(.Range(myAddr(iCtr)).Value)
myCell.Characters(oCtr + cCtr, 1).Font.Name _
= .Range(myAddr(iCtr)).Characters(cCtr, 1).Font.Name
Next cCtr
oCtr = oCtr + Len(.Range(myAddr(iCtr)).Value)
Next iCtr
End With

End Sub

 

[Guest]

Thanks for your help Dave

You could use a subroutine that concatenates the strings and then goes back and
fixes the font for each character.

But you have to extract each font attribute that you want (name, boldness,
color, etc).

This example takes the values in A1:A3 and concatenates them into A4. And then
just keeps track of the font.name for each character.

Option Explicit
Sub testme()

Dim myStr As String
Dim myAddr As Variant
Dim myCell As Range
Dim iCtr As Long
Dim cCtr As Long
Dim oCtr As Long

myAddr = Array("a1", "a2", "a3")

With ActiveSheet
Set myCell = .Range("a4")
myStr = ""
For iCtr = LBound(myAddr) To UBound(myAddr)
myStr = myStr & .Range(myAddr(iCtr)).Value
Next iCtr

myCell.Value = myStr

oCtr = 0
For iCtr = LBound(myAddr) To UBound(myAddr)
For cCtr = 1 To Len(.Range(myAddr(iCtr)).Value)
myCell.Characters(oCtr + cCtr, 1).Font.Name _
= .Range(myAddr(iCtr)).Characters(cCtr, 1).Font.Name
Next cCtr
oCtr = oCtr + Len(.Range(myAddr(iCtr)).Value)
Next iCtr
End With

End Sub