ConcatenateRange while maintaining field formatting

[Swish77]

This question will require VBA. I have a macro that allows me to concatenate a range of cells separated by a comma and skipping empty spaces. However, the cells I want to concatenate have colored text, and it's important I be able to keep the respective colors. Here's the macro I'm currently using to concatenate a range of cells. Any ideas on how to alter this, so that values will retain color? Also, these values are text values resulting from formulas- not straight text. Thanks in advance for your help. Here is the VBA language I'm currently using:


Function ConcatenateRange(ByVal cell_range As Range, _
Optional ByVal seperator As String) As String
Dim cell As Range
Dim newString As String
Dim cellArray As Variant
Dim i As Long, j As Long
seperator = ", "
cellArray = cell_range.Value
For i = 1 To UBound(cellArray, 1)
For j = 1 To UBound(cellArray, 2)
If Len(cellArray(i, j)) <> 0 Then
newString = newString & (seperator & cellArray(i, j))
End If
Next
Next
If Len(newString) <> 0 Then
newString = Right$(newString, (Len(newString) - Len(seperator)))
End If
ConcatenateRange = newString
End Function

 

[XLfriend777]

Hi Swish77 - Welcome to the forum. You might consider something like the code below which copies and then pastes the formatting from Column C into Column E. Hope that helps get things started.

Sub Swish77_CopyPasteFormatting()
    Columns("C:C").Select
    Selection.Copy
    Columns("E:E").Select
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
End Sub

 

[tonyyy]

Swish77,

Welcome to the Board.

So, I wasn't able to modify your Function code to retain font colors, but did manage to write a sub routine that concatenates and retains font colors...

Sub ColorConcatenate()
Dim r As Long, c As Long
Dim fnt As Long, lnth As Long, totalLnth As Long
Dim rng As Range, rng2 As Range
Dim str As String

Set rng = Application.InputBox("Please select a range to concatenate.", Type:=8)
Set rng2 = Application.InputBox("Please select a cell for the result.", Type:=8)

totalLnth = 1
For r = 1 To rng.Rows.Count
    For c = 1 To rng.Columns.Count
        str = str & ", " & rng.Item(r, c).Value
    Next c
Next r

rng2 = Right(str, (Len(str) - 2))
For r = 1 To rng.Rows.Count
    For c = 1 To rng.Columns.Count
        fnt = rng.Item(r, c).Font.Color
        lnth = Len(rng.Item(r, c))
        rng2.Characters(Start:=totalLnth, Length:=lnth).Font.Color = fnt
        totalLnth = totalLnth + lnth + 2
    Next c
Next r
End Sub

Once initiated, the macro will prompt you to select a range to concatenate, then prompt you to select a cell for the result.

Cheers,

tonyyy