Excel & VBA – Concatenating two fields together with formatting

A work colleague asked me to do a “Mate’s rate” job for his team yesterday.

They had a MS Word document with a huge table in it that they needed to convert to Excel to load into an application.

Paraphrased  it looked like this:

My first thought was to copy this table out and paste it into excel to see how it looks:

Two problems:

1. The cell “Some data” is merged across three rows
2. Line 1, Line 2, Line 3 are now split across three rows instead of being in the one cell

I wrote a macro to split out the merge cells; but when it came to combining cells for Line 1, Line 2 and Line 3 I ran into a problem.

None of the usual commands and from my quick google searching could combine the cells and retained the formatting.

So commands like:

=CONCAT(B2:B4)

=B2 & B3 & B4

Would not retain the formatting; let alone add in line feed characters to make it a multiline cell

I’m sure there is a better way – but strapped for time I programmed the following subroutine in VBA

Public Sub combineCells(cell1 As Range, cell2 As Range, output As Range)
    Dim formatIndex As Long
    Dim formatOffset As Long
    Dim hyperlink1 As String
    Dim hyperlink2 As String

    hyperlink1 = ""
    hyperlink2 = ""

    ' Check if the cell has a hyperlin; but don't have a text version of the hyperlink in the Value 2
    If cell1.Hyperlinks.Count <> 0 And InStr(cell1.Value2, "https:") < 1 Then
        hyperlink1 = " [" & cell1.Hyperlinks(1).Address & "]"
    End If

    If cell2.Hyperlinks.Count <> 0 And InStr(cell2.Value2, "https:") < 1 Then
        hyperlink2 = " [" & cell2.Hyperlinks(1).Address & "]"
    End If

 
    ' Handling if the first cell is blank.  If so we don't want a LF at the top of the cell
    If Trim(cell1.Value2) <> "" Then
        output.Value2 = cell1.Value2 & hyperlink1 & vbLf & cell2.Value2 & hyperlink2
        formatOffset = Len(cell1.Value2) + Len(hyperlink1) + 1
    Else
        output.Value2 = cell2.Value2 & hyperlink2
        formatOffset = Len(cell1.Value2)
    End If

  
    ' Copies the formatting from cell1 to the final cell
    ' You can add more options to transfer over different formatting
    For formatIndex = 1 To Len(cell1.Value2)
        output.Characters(formatIndex, 1).Font.Bold = cell1.Characters(formatIndex, 1).Font.Bold
        output.Characters(formatIndex, 1).Font.Italic = cell1.Characters(formatIndex, 1).Font.Italic
        'output.Characters(formatIndex, 1).Font.Underline = cell1.Characters(formatIndex, 1).Font.Underline
    Next

  
    ' Copies the formatting from cell2 to the final cell
    For formatIndex = 1 To Len(cell2.Value2)
        output.Characters(formatIndex + formatOffset, 1).Font.Bold = cell2.Characters(formatIndex, 1).Font.Bold
        output.Characters(formatIndex + formatOffset, 1).Font.Italic = cell2.Characters(formatIndex, 1).Font.Italic
        'output.Characters(formatIndex + formatOffset, 1).Font.Underline = cell2.Characters(formatIndex, 1).Font.Underline
    Next

End Sub

Oh boy it runs slow – to combine a couple of thousands cells took half an hour and I had the typical worries that Excel crashed because everything was locked up.

But it worked for the quick task that I was doing