Concatenate cells but keep formatting of text from source cells

[JULIANAo]

I have been trying to concatenate cells from a different master sheet into one cell for a label.
the problem is that some parts of the text are bold (for allergens) and when I finish it erases all the formatting from original cell.
I've tried several different macros and nothing works. Please help me!! I've tried everything I could search or think of.

My formula and what I get:

what I need:

 

[JULIANAo]

Sure. Assuming the original formula is still in E35:
1. Right click the 'APP' sheet name tab and choose "View Code".
2. Copy and Paste the code below into the main right hand pane that opens at step 1.
3. Edit the code to reflect where you have made the new merged area. I have used M3 so just edit that (twice) in the code.
4. Close the Visual Basic window & test by making whatever change you need to to get a different result in E35.

Private Sub Worksheet_Calculate()
  Dim RX As Object, M As Object
 
  If Range("E35").Value <> Range("M3").Value Then
    Set RX = CreateObject("VBScript.RegExp")
    RX.Global = True
    RX.IgnoreCase = True
    With Sheets("Ingredients")
      RX.Pattern = "\b(" & Application.TextJoin("|", 1, .Range("P3", .Range("P" & Rows.Count).End(xlUp)).Value) & ")\b"
    End With
    With Range("M3")
      .Font.Bold = False
      .Value = Range("E35").Value
      For Each M In RX.Execute(.Value)
        .Characters(M.firstindex + 1, Len(M)).Font.Bold = True
      Next M
    End With
  End If
End Sub

it works wonders!! you're a legend!! ?
Sorry to keep on with the questions, do you think the code can work for a range(several different labels)
for example; source instead of only E35 would be I4:I58 and the result instead of M3 only it would be (S4:S58)?

 

[Peter_SSs]

do you think the code can work for a range(several different labels)
for example; source instead of only E35 would be I4:I58 and the result instead of M3 only it would be (S4:S58)?

It could, but it looks like your merged cell (was 355but now I something) is a multi-row merged cell. If so then we wouldn't be checking I4, I5, I6 etc. Possibly I4, I10, I16 or something similar. Can you confirm what the top row of the (first few) merged cells are?

 

[JULIANAo]

It could, but it looks like your merged cell (was 355but now I something) is a multi-row merged cell. If so then we wouldn't be checking I4, I5, I6 etc. Possibly I4, I10, I16 or something similar. Can you confirm what the top row of the (first few) merged cells are?

I've decided to put all the labels together in one sheet so it is easier to reference them. Also, no more merged cells.
this is what will look like: cells with the original formula would be column I and the final result column S.
Thanks so much again!

 

[Peter_SSs]

no more merged cells.

That is good as merged cells often end up causing problems in vba code.

cells with the original formula would be column I and the final result column S.

Try this version. The code goes in the module of the sheet where the formula & labels are - previously that was 'APP' but from your image now looks to be the 'COMBINED ...' worksheet.

Private Sub Worksheet_Calculate()
  Dim RX As Object, M As Object
  Dim c As Range
  
  For Each c In Range("S4:S58")
    If Intersect(c.EntireRow, Columns("I")).Value <> c.Value Then
      Set RX = CreateObject("VBScript.RegExp")
      RX.Global = True
      RX.IgnoreCase = True
      With Sheets("Ingredients")
        RX.Pattern = "\b(" & Application.TextJoin("|", 1, .Range("P3", .Range("P" & Rows.Count).End(xlUp)).Value) & ")\b"
      End With
      With c
        .Font.Bold = False
        .Value = Intersect(c.EntireRow, Columns("I")).Value
        For Each M In RX.Execute(.Value)
          .Characters(M.firstindex + 1, Len(M)).Font.Bold = True
        Next M
      End With
    End If
  Next c
End Sub

 

[JULIANAo]

That is good as merged cells often end up causing problems in vba code.


Try this version. The code goes in the module of the sheet where the formula & labels are - previously that was 'APP' but from your image now looks to be the 'COMBINED ...' worksheet.

Private Sub Worksheet_Calculate()
  Dim RX As Object, M As Object
  Dim c As Range
 
  For Each c In Range("S4:S58")
    If Intersect(c.EntireRow, Columns("I")).Value <> c.Value Then
      Set RX = CreateObject("VBScript.RegExp")
      RX.Global = True
      RX.IgnoreCase = True
      With Sheets("Ingredients")
        RX.Pattern = "\b(" & Application.TextJoin("|", 1, .Range("P3", .Range("P" & Rows.Count).End(xlUp)).Value) & ")\b"
      End With
      With c
        .Font.Bold = False
        .Value = Intersect(c.EntireRow, Columns("I")).Value
        For Each M In RX.Execute(.Value)
          .Characters(M.firstindex + 1, Len(M)).Font.Bold = True
        Next M
      End With
    End If
  Next c
End Sub

That works like a charm! THANK YOU SO MUCH!!!! its been ages trying to get this done, I can finally sleep at night! LEGEND!

 

[Peter_SSs]

You're welcome. Thanks for the follow-up.

Looks like I was in too much of a hurry to modify the previous code though. It would be better not to keep repeating the RX setup every time through the loop. It would be more efficient this way.

Private Sub Worksheet_Calculate()
  Dim RX As Object, M As Object
  Dim c As Range
 
  Set RX = CreateObject("VBScript.RegExp")
  RX.Global = True
  RX.IgnoreCase = True
  With Sheets("Ingredients")
    RX.Pattern = "\b(" & Application.TextJoin("|", 1, .Range("P3", .Range("P" & Rows.Count).End(xlUp)).Value) & ")\b"
  End With
  For Each c In Range("S4:S58")
    If Intersect(c.EntireRow, Columns("I")).Value <> c.Value Then
      With c
        .Font.Bold = False
        .Value = Intersect(c.EntireRow, Columns("I")).Value
        For Each M In RX.Execute(.Value)
          .Characters(M.firstindex + 1, Len(M)).Font.Bold = True
        Next M
      End With
    End If
  Next c
End Sub

 

[JULIANAo]

You're welcome. Thanks for the follow-up.

Looks like I was in too much of a hurry to modify the previous code though. It would be better not to keep repeating the RX setup every time through the loop. It would be more efficient this way.

Private Sub Worksheet_Calculate()
  Dim RX As Object, M As Object
  Dim c As Range
 
  Set RX = CreateObject("VBScript.RegExp")
  RX.Global = True
  RX.IgnoreCase = True
  With Sheets("Ingredients")
    RX.Pattern = "\b(" & Application.TextJoin("|", 1, .Range("P3", .Range("P" & Rows.Count).End(xlUp)).Value) & ")\b"
  End With
  For Each c In Range("S4:S58")
    If Intersect(c.EntireRow, Columns("I")).Value <> c.Value Then
      With c
        .Font.Bold = False
        .Value = Intersect(c.EntireRow, Columns("I")).Value
        For Each M In RX.Execute(.Value)
          .Characters(M.firstindex + 1, Len(M)).Font.Bold = True
        Next M
      End With
    End If
  Next c
End Sub

Thank you so much!?