Concatenar celdas manteniendo dos colores

[miguel.sme]

Buenas tardes,

tengo esta macro que lee caracter a caracter y los concatena con su mismo formato, en este caso concatena manteniendo color de ambas celdas.

La he probado y es muy lenta cuando hay muchas lineas con muchos carcateres en cada celda.

Como en realidad sólo tengo texto en dos colores que se encuentran siempre en celdas separadas, no sé si se podría optimizar y hacerla más rápida y ligera.

Os copio el código y adjunto ejemplo:

Sub COPYPASTECOLORINDEX()
Set myRange = Range("A:B") 'aquí le digo el rango del aprimera columna
For Each c In myRange.Cells
    If c.Value <> "" Then
        If c.Offset(0, 1).Value = "" Then
            c.Offset(0, 2).Value = c.Value
        Else
            c.Offset(0, 2).Value = c.Value & Chr(10) & c.Offset(0, 1).Value
            'c.Offset(0, 2).Characters(Len(CStr(c.Value)) + 2, Len(CStr(c.Offset(0, 1).Value))).Font.ColorIndex = c.Offset(0, 1).Characters(Len(CStr(c.Value))).Font.ColorIndex
        End If
    End If
   
       For i = 1 To Len(CStr(c.Value))
   c.Offset(0, 2).Characters(i, 1).Font.ColorIndex = c.Characters(i, 1).Font.ColorIndex
   Next i
          For j = 1 To Len(CStr(c.Offset(0, 1).Value))
   c.Offset(0, 2).Characters(i + j, 1).Font.ColorIndex = c.Offset(0, 1).Characters(j, 1).Font.ColorIndex
   Next j
Next c
End Sub

 

 

colores.xlsx.xlsm

[miguel.sme]

Como sólo son dos colores, y además un color en cada celda,  he cambiado a esta macro:

 

Sub concatenarycolor1()

Dim uA, i&

uA = Range("A" & Rows.Count).End(xlUp).Row

For i = uA To 1 Step -1
    
    If Cells(i, "A") <> 0 Or Cells(i, "A") <> "#n/d" Then
   
        Value1 = ActiveCell.Value
        Color1 = ActiveCell.Font.Color
        Len1 = Len(Value1)

    ActiveCell.Offset(0, 1).Range("A1").Select
        Value2 = ActiveCell.Value
        Color2 = ActiveCell.Font.Color
        Len2 = Len(Value2)

    ActiveCell.Offset(0, 1).Range("A1").Select
    ActiveCell.Value = Value1 & Chr(10) & Value2

        With ActiveCell.Characters(Start:=1, Length:=Len1).Font
         .Color = Color1
        End With
        
        With ActiveCell.Characters(Start:=Len1 + 2, Length:=Len2).Font
         .Color = Color2
        End With

      ActiveCell.Offset(1, -2).Range("A1").Select

    End If

Next i

End Sub

 

Pero encuentro un problema,  no quiero unir las dos celdas que contengan un 0 o "#n/d" o un espacio en blanco. En ese caso sólo debería elegir el valor de la otra celda que tiene contenido disitinto a éstos. La que no tiene ese valor. Actualmente está uniendo ambas celdas en todos los casos.

Adjunto ejemplo.

 

concatenarycolor.XLSB