The hardest question in Excel History: A very smart VBA macro to combine cell with their styles?

[McExcel]

As title, is it possible?

I think that's the hardest question in Excel history (about style). And I think no one can solve that without build Excel.

	A	B	C	D	E	F
1	MREXCEL	Your	One Stop	for	EXCEL	Tips & Solutions

<tbody>
</tbody>

=MagicalConcat(A1 , B1 , C1 , D1 , E1 , F1)

MREXCEL Your One Stop for EXCEL Tips & Solutions

<tbody>
</tbody>

 

[BobUmlas]

Can't be done, even with macro. A formula cannot return varying text fonts, sizes, etc. Not a hard question at all -- quite simple. Answer is no.

 

[Rick Rothstein]

As title, is it possible?

I think that's the hardest question in Excel history (about style). And I think no one can solve that without build Excel.

	A	B	C	D	E	F
1	MREXCEL	Your	One Stop	for	EXCEL	Tips & Solutions

<tbody>
</tbody>

=MagicalConcat(A1 , B1 , C1 , D1 , E1 , F1)

MREXCEL Your One Stop for EXCEL Tips & Solutions

<tbody>
</tbody>

A formula cannot produce output where the text has mixed formatting. It should be possible to write a VBA event procedure to replace the use of a formula to simulate what you want... would that be acceptable?

 

[McExcel]

A formula cannot produce output where the text has mixed formatting. It should be possible to write a VBA event procedure to replace the use of a formula to simulate what you want... would that be acceptable?

Sorry, formula is not important. I want to say that the macro read the cells with its style and then combine to anothers.

 

[Steph77]

What you could do is to make a text box using VBA with mixed formatting and size it exactly over the cell you want to contain the output you describe. I've never written code to change formats like this inside a text box though so (a) I don't know if it's definitely possible and (b) If it is possible someone else would have to show you how to do it.

 

[Rick Rothstein]

Sorry, formula is not important. I want to say that the macro read the cells with its style and then combine to anothers.

Give this macro a try...

Sub ConcatWithStyles()
  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
End Sub

 

[McExcel]

Give this macro a try...

Sub ConcatWithStyles()
  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
End Sub

Sorry for my slow English. I've seen it this morning, but I couldn't test and give a reply quickly.

OMGGGGG ! ROCKS ! WORKS LIKE A CHARM !

PROBLEM IS SOLVED !

Dear Rick, you're my hero. Nearly 10 years I was waiting new Excel version for this feature. How could I be so stupid, I could try learn macro instead of waiting.

This problem is very very important for me as part of my job. I tried ask some Excel experts on my local area. But no one can solve. They say that so hard ~nearly impossible. But now your knowledge overcomes greatly.

Microsoft should do that for everyone.

This macro should be shared on best useful macro samples.

Great thanks again.

 

[par60056]

Give this macro a try...

Very nice Rick. I knew it could be done with a macro and was just about to do it but you beat me there.

 

[McExcel]

Give this macro a try...

Dear Rick,

Let's assume the inputs are A1:F1 and the output is H1.

I want also
the inputs are A2:F2 and the output is H2
the inputs are A3:F3 and the output is H3
the inputs are A4:F4 and the output is H4
...
the inputs are A255:F255 and the output is H255

Is there any way to convert your macro for batch processes? Like that: Array of VBA event procedures

Thank you very much for your support.

 

[par60056]

Then you need to write a loop around it and process each row.

Something like:

Sub ConcatWithStyles()
  Dim X As Long, Cell As Range, Text As String, Position As Long
  Dim lastRow As Long, currRow As Long
  
  lastRow = Range("A1").End(xlDown).Row
  For currRow = 1 To lastRow
    Cells(currRow, 8).Value = Space(Evaluate("SUM(LEN(A" & currRow & ":F" & currRow & "))+COLUMNS(A" & currRow & ":F" & currRow & ")-1"))
    Position = 1
    Application.ScreenUpdating = False
    For Each Cell In Range(Cells(currRow, 1), Cells(currRow, 6))
      With Cells(currRow, 8)
        .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
  Next
  Application.ScreenUpdating = True
End Sub