Need VBA code to concatenate and preserve formatting

Could anyone show me some code to automatically concatenate a range of cells whilst preserving the original formatting?

My document consists of around 200 columns and 16000 rows. Each row needs to be concatenated into column A with a "/" delimiter and preserve the original font (around 20 columns have red font which needs to be included in the destination cell).

Many thanks

If this helps, here is some code that I picked up previously and was trying to adapt for my needs (Credit to Erik Van Geit from Mr.Excel boards).

Option Explicit

Sub test()
Call concatenate_cells_formats(Range("A1"), Range("B1:GI1"))
End Sub

Sub concatenate_cells_formats(Cell As Range, source As Range)

Dim c As Range
Dim i As Integer

i = 1

    With Cell
    .Value = vbNullString
    .ClearFormats
    
        For Each c In source
        .Value = .Value & " " & Trim(c)
        Next c

    .Value = Trim(.Value)

        For Each c In source
            With .Characters(Start:=i, Length:=Len(Trim(c))).Font
            .Name = c.Font.Name
            .FontStyle = c.Font.FontStyle
            .Size = c.Font.Size
            .Strikethrough = c.Font.Strikethrough
            .Superscript = c.Font.Superscript
            .Subscript = c.Font.Subscript
            .OutlineFont = c.Font.OutlineFont
            .Shadow = c.Font.Shadow
            .Underline = c.Font.Underline
            .ColorIndex = c.Font.ColorIndex
            End With
            .Characters(Start:=i + Len(c), Length:=1).Font.Size = 1
        i = i + Len(Trim(c)) + 1
        Next c

    End With

End Sub

How can I make this work automatically for all 16000 rows in my document and include the "/" delimiter?

Here's your code modified.

Sub test()
    Dim cell   As Range
    Application.ScreenUpdating = False
    For Each cell In Range("B2", Range("B" & Rows.Count).End(xlUp))
        Call concatenate_cells_formats(cell.Offset(, -1), cell.Resize(, 5)) 'Destination column A, Source B:F
    Next cell
    Application.ScreenUpdating = True
End Sub

Sub concatenate_cells_formats(cell As Range, source As Range)

    Dim c      As Range
    Dim i      As Integer

    i = 1

    With cell
    
        .Value = vbNullString
        .ClearFormats

        For Each c In source
            If Len(c.Value) Then .Value = .Value & "/" & Trim(c)
        Next c
        
        .Value = Trim(Mid(.Value, 2))

        For Each c In source
        
            With .Characters(Start:=i, Length:=Len(Trim(c))).Font
                .Name = c.Font.Name
                .FontStyle = c.Font.FontStyle
                .Size = c.Font.Size
                .Strikethrough = c.Font.Strikethrough
                .Superscript = c.Font.Superscript
                .Subscript = c.Font.Subscript
                .OutlineFont = c.Font.OutlineFont
                .Shadow = c.Font.Shadow
                .Underline = c.Font.Underline
                .ColorIndex = c.Font.ColorIndex
            End With
            
            .Characters(Start:=i + Len(c) + 1, Length:=1).Font.Size = 1
            i = i + Len(Trim(c)) + 1

        Next c

    End With

End Sub

Thank you very much AlphaFrog, that works perfectly.

Hi, LexicOn,

Could you please provide the sample file with the correct VBA code for reference.