Concatenate with style

**Abdul** · 12-06-2020, 10:46 PM

Hello Excel Experts,
Below VBA was posted by Mr Rick Rothstein
I want some change in this below VB. If any cell from A to Z contains a formula like =Sheet1!A5&" "&Sheet1!C7 or =Sheet1!A5*3 etc it shows Runtime error '1004. How to solve this error.

Code:

Sub ConcatWithStyles()
  Dim X As Long, Cell As Range, Text As String, Position As Long
  Range("A3").Value = Space(Evaluate("SUM(LEN(A1:Z1))+COLUMNS(A1:Z1)-1"))
  Position = 1
  Application.ScreenUpdating = False
  For Each Cell In Range("A1:Z1")
  
    With Range("A3")
      .Characters(Position, Len(Cell.Value)).Text = Cell.Characters(1, Len(Cell.Value)).Text
      For X = 1 To Len(Cell.Value)
        With .Characters(Position + X - 1, 1).Font
          .Name = Cell.Characters(X, 1).Font.Name
          .Size = Cell.Characters(X, 1).Font.Size
          .Bold = Cell.Characters(X, 1).Font.Bold
          .Italic = Cell.Characters(X, 1).Font.Italic
          .Underline = Cell.Characters(X, 1).Font.Underline
          .Color = Cell.Characters(X, 1).Font.Color
          .Strikethrough = Cell.Characters(X, 1).Font.Strikethrough
          .Subscript = Cell.Characters(X, 1).Font.Subscript
          .Superscript = Cell.Characters(X, 1).Font.Superscript
          .TintAndShade = Cell.Characters(X, 1).Font.TintAndShade
          .FontStyle = Cell.Characters(X, 1).Font.FontStyle
        End With
      Next
    End With
    Position = Position + Len(Cell.Value) + 1
  Next
  Application.ScreenUpdating = True
End Sub

Thanks in advance

**DocAElstein** · 12-07-2020, 01:32 AM

Hello Abdul
Welcome to ExcelFox

I am not familiar with the macro you posted : I am not sure what it is supposed to do.

Can you please:
_ Tell us where you got it from ( give us the URL link )
_ Explain in as much detail as you can what it is you want to do. Possibly it would be helpful to also upload a sample file to help explain

If no one else can help, then I will take another look , possibly tomorrow

Alan

**Abdul** · 12-07-2020, 09:02 PM

Originally Posted by DocAElstein

Hello Abdul
Welcome to ExcelFox

I am not familiar with the macro you posted : I am not sure what it is supposed to do.

Can you please:
_ Tell us where you got it from ( give us the URL link )
_ Explain in as much detail as you can what it is you want to do. Possibly it would be helpful to also upload a sample file to help explain

If no one else can help, then I will take another look , possibly tomorrow

Alan

Thanks for reply sir.
here is link
https://www.mrexcel.com/board/thread.../#post-3954687

**DocAElstein** · 12-08-2020, 05:23 PM

Here is a simple quick solution idea.
It stores the formulas, then replaces all formulas with their values, then runs Ricks coding, then replaces the formulas

I am using, as an example, a similar example to that at the referenced link ( https://www.mrexcel.com/board/thread.../#post-3953353 )

I have this worksheet example, where I have a formula in the first cell:
RicksConcatWithStylesBefore.JPG : http://i.imgur.com/PlcxFab.jpg

_____ Workbook: RicksConcatWithStyles.xls ( Using Excel 2007 32 bit )

_Row\^Col	A	B	C	D	E	F
1	excel fox	The	thinking	man's	MrEXCEL	Tips & Solutions
2
3
4	excel
5
6
7			fox

Worksheet: Sheet1
_____ Workbook: RicksConcatWithStyles.xls ( Using Excel 2007 32 bit )

_Row\^Col	A	B	C	D	E	F
1	=Sheet1!A4 & " " & Sheet1!C7	The	thinking	man's	MrEXCEL	Tips & Solutions
2
3
4	excel
5
6
7			fox

Worksheet: Sheet1

After running the macro you will get this:
RicksConcatWithStylesAfter.JPG : http://i.imgur.com/3pvfB7n.jpg

Alan

P.S:
Note: This solution is not perfect. If you have different styles or formatting for characters within a cell then some of the formatting is lost
Example:
Before: http://i.imgur.com/iv5yI4t.jpg

After: http://i.imgur.com/IKxx7nj.jpg

Macro here: https://excelfox.com/forum/showthrea...ll=1#post15166
Also macro is in uploaded file, RicksConcatWithStyles.xls : https://app.box.com/s/n3rfg981htv37p5xjfz9y4v17ycoybqe

**DocAElstein** · 12-08-2020, 06:01 PM

This slightly modified version will help get over the issue of different character formats within a cell.
In this version, only cells with formulas are subject to having that formula stored, replaced with values , and then replaced after Rick's coding

Code:

Sub ConcatWithStyles2() '  https://www.mrexcel.com/board/threads/the-hardest-question-in-excel-history-a-very-smart-vba-macro-to-combine-cell-with-their-styles.808781/#post-3954687
Rem 0a save any formulas, and replace with values
Dim arrFormulas(1 To 5) As Variant
Dim cnt
    For cnt = 1 To 5
        If Left(Cells.Item(1, cnt).Formula, 1) = "=" Then ' case a formula in cell
         Let arrFormulas(cnt) = Cells.Item(1, cnt).Formula
         Let Cells.Item(1, cnt).Value = Cells.Item(1, cnt).Value
        Else
        ' we don't have a formula , so we do nothing to the cell
        End If
    Next cnt
  Dim X As Long, Cell As Range, Text As String, Position As Long
  Range("A3").Value = Space(Evaluate("SUM(LEN(A1:F1))+COLUMNS(A1:F1)-1"))
  Position = 1
'  Application.ScreenUpdating = False
  For Each Cell In Range("A1:F1")
    With Range("A3")
      .Characters(Position, Len(Cell.Value)).Text = Cell.Characters(1, Len(Cell.Value)).Text
      For X = 1 To Len(Cell.Value)
        With .Characters(Position + X - 1, 1).Font
          .Name = Cell.Characters(X, 1).Font.Name
          .Size = Cell.Characters(X, 1).Font.Size
          .Bold = Cell.Characters(X, 1).Font.Bold
          .Italic = Cell.Characters(X, 1).Font.Italic
          .Underline = Cell.Characters(X, 1).Font.Underline
          .Color = Cell.Characters(X, 1).Font.Color
          .Strikethrough = Cell.Characters(X, 1).Font.Strikethrough
          .Subscript = Cell.Characters(X, 1).Font.Subscript
          .Superscript = Cell.Characters(X, 1).Font.Superscript
          .TintAndShade = Cell.Characters(X, 1).Font.TintAndShade
          .FontStyle = Cell.Characters(X, 1).Font.FontStyle
        End With
      Next
    End With
    Position = Position + Len(Cell.Value) + 1
  Next
  Application.ScreenUpdating = True
Rem 0b Put the formulas back
    For cnt = 1 To 5
        If arrFormulas(cnt) <> "" Then ' case a formula was in cell
         Let Cells.Item(1, cnt).Formula = arrFormulas(cnt)
        
        Else
        ' we didnt have a formula , so we do nothing to the cell
        End If
    Next cnt

End Sub

Before:
http://i.imgur.com/gqW322Y.jpg

After running above macro:
http://i.imgur.com/792PzQY.jpg

**Abdul** · 12-08-2020, 08:13 PM

Wow nice, Thanks once again for your quick response,
one little problem is there, if any cell contain a number (value) it shows run time error 1004, and if given range contains more than 230 characters VBA not works the destination cell (A3) will become blank.

**DocAElstein** · 12-09-2020, 08:28 PM

Hello Abdul

Originally Posted by Abdul

...if any cell contain a number (value) it shows run time error 1004

This change seems to overcome that problem:
Change

Code:

.Characters(Position, Len(Cell.Value)).Text = Cell.Characters(1, Len(Cell.Value)).Text

to

Code:

.Characters(Position, Len(Cell.Value)).Text = Cell.Value

Originally Posted by Abdul

... if given range contains more than 230 characters VBA not works the destination cell (A3) will become blank

I do not understand this problem.

Can you provide a sample to demonstrate the problem?
I will then investigate further

Alan

**Abdul** · 12-10-2020, 07:33 PM

I do not understand this problem.

Can you provide a sample to demonstrate the problem?
I will then investigate further

Alan

Please check the attached file,

**DocAElstein** · 12-11-2020, 05:49 PM

Hello Abdul.
This is an interesting problem. I am both _...
_ not sure yet of exactly what is causing this problem: It may be a Bug or just a characteristic or a feature to which I can find no documentation.
_ not sure yet of what would be a full solution.

I will investigate the problem again when I have more time.

In the meantime I have a temporary workaround that works on your test data,
Sub ConcatWithStylesTemporarySolution()
You may be able to adapt that to other data.
If you have problems adapting that macro to other data, then , if you can post again some different test data, and then will try to find a solution again for you.

Temporary Solution
The macro below , I think , appears to give your desired output. ( In the uploaded workbook, RicksConcatWithStyles.xls , I am using a worksheet with the name of ChrTextLimit. The macro gives your full concatenated string output with styles in cell A30 in worksheet ChrTextLimit

I will investigate this issue further when I have time. ( I have started a test post, which I will post further in later https://excelfox.com/forum/showthrea...ng-with-styles )

Alan

Code:

Sub ConcatWithStylesTemporarySolution() '  https://excelfox.com/forum/showthread.php/2679-Concatenate-with-style?p=15172&viewfull=1#post15172
Rem 0 Worksheets info
Dim WsTest As Worksheet: Set WsTest = ThisWorkbook.Worksheets("ChrTextLimit")
Rem 1 concatenate text strings
'1a  make a formula  for the concatenated cells text
Dim Cnt As Long
    For Cnt = 1 To 16 '  16 is for column P
    Dim strCelText As String
     Let strCelText = strCelText & WsTest.Cells(1, Cnt).Address & " & " & """ """ & " & "
    Next Cnt
 Let strCelText = Left(strCelText, Len(strCelText) - 8) ' take off last  " & "  and  " "  and  " & "
 Let strCelText = "=" & strCelText ' This makes the text string appear to Excel VBA as a formula
'Debug.Print strCelText
' 1b  put the full concatenated text string into a cell
 WsTest.Range("A30").Clear
 Let WsTest.Range("A30").Value = strCelText
 Let WsTest.Range("A30").Value = WsTest.Range("A30").Value ' after this we now have the full text that we want, but it is all in the same  Font  styles
Rem 2 add the styles
Dim Position As Long: Let Position = 1 ' This varible holds the start position (within the full concatenated string) of the next text section under consideration , so at the begining it is 1
Dim ACel As Range
    For Each ACel In Range("A1:P1") ' for each of the cells in the range of text to be concatenated with styles
        With WsTest.Range("A30").Characters(Position, Len(ACel.Value)).Font '  this is the text section within the concatenated string corrsponding to the text from the curren  ACel  cell
          .Name = ACel.Font.Name ' I am giving the text section within the long concatenated string ( LHS ) , the style from the current  ACel  cell
          .Size = ACel.Font.Size
          .Bold = ACel.Font.Bold
          .Italic = ACel.Font.Italic
          .Underline = ACel.Font.Underline
          .Color = ACel.Font.Color
          .Strikethrough = ACel.Font.Strikethrough
          .Subscript = ACel.Font.Subscript
          .Superscript = ACel.Font.Superscript
          .TintAndShade = ACel.Font.TintAndShade
          .FontStyle = ACel.Font.FontStyle
         Let Position = Position + Len(ACel.Value) + 1 ' This takes us to posiion at the end of the current cell text  +1  ( +1 is for the extra space )
        End With
    Next ACel
End Sub