Excel VBA Macro to Efficiently Combine & Preserve Formatting (Bold) in 120 Text Cells

I need a macro that will combine text from cells into one, preserving the format in cells, and more specifically bold text.
I have a working macro here but it loads my computer terribly, I need to modify it and make it work smoothly for 120 cells
Private Sub CommandButton61_Click ()
Application.ScreenUpdating = False

Dim sheet As Excel.Worksheet, ostAC As Long
Dim rng3 Cells As Excel.Range, kom As Excel.Range
Dim komCel As Excel.Range
Dim poz1 As Integer, poz2 As Integer


Columns ( "ER ER"). Select
Selection.ClearContents
Range ( "F70"). ClearContents
Const iCelOdKolAOffset As Integer = 121
Set sheet = ThisWorkbook.Worksheets ("Sheet1")
With sheet
ostAC = Last (.Columns ("AA: EJ"))
Set rng3Cells = .Range ("AA100: EJ100")
To Until rng3Komorki.Row> ostAC
Set komCel = rng3Komorki.Cells (1) .Offset (, iCelOdKolAOffset)
komCel.Clear
For Each kom In rng3Cells
komCel = komCel & "" & kom
Next
For Each kom In rng3Cells
pos1 = IIf (pos1 = 0, 2, pos1 + pos2 + 1)
pos2 = Len (kom)

With komCel.Characters (Start: = poz1, Length: = poz2)
.Bold = Mobile.Bold
End with
Next
Set rng3Cells = rng3Cells.Offset (1)
pos1 = 0: pos2 = 0
Loop
End with
Set rng3Komorki = Nothing
Set sheet = Nothing
Application.ScreenUpdating = True
Range ( "ER100"). Select
Selection.Copy
Range ( "F70"). Select
ActiveSheet.Paste

End Sub

Function Last (rng As Range)
On Error Resume Next
Last = rng.Find (What: = "*", _
After: = rng.Cells (1), _
Lookat: = xlPart, _
LookIn: = xlFormulas, _
SearchOrder: = xlByRows, _
SearchDirection: = xlPrevious, _
MatchCase: = False) .Row
On Error GoTo 0

End Function