Copier des cellules en dessous sans les textes soulignées ou de couleur

Sub copy_Texte_Dessous_Sans_Barre()
Dim Cell As Range, i As Long, Texte As String
    For Each Cell In Range("B2:C2")
        Texte = ""
        For i = 1 To Len(Cell)
            With Cell.Characters(Start:=i, Length:=1).Font
                If .Underline = xlUnderlineStyleNone And (.ColorIndex = 1 Or .ColorIndex = xlAutomatic) Then
                    Texte = Texte & Mid(Cell.Value, i, 1)
                End If
            End With
        Next
        Cell.Offset(1, 0).Value = Texte
    Next
End Sub

If Left(Texte, 1) = Chr(10) Then Texte = Right(Texte, Len(Texte) - 1)
        If Right(Texte, 1) = Chr(10) Then Texte = Left(Texte, Len(Texte) - 1)

Sub copy_Texte_Dessous_Sans_Barre2()
'TototTiti
Dim Cell As Range, i As Long, Texte As String
    
    For Each Cell In Range(Range("B2:C2").Address)
    'MsgBox Len(Cell)
        Texte = ""
        For i = 1 To Len(Cell)
          With Cell.Characters(Start:=i, Length:=1).Font
            
                If .Underline = xlUnderlineStyleNone And (.ColorIndex = 1 Or .ColorIndex = xlAutomatic) Then
                    Texte = Texte & Mid(Cell.Value, i, 1)
           End If
          End With
        Next
        If Left(Texte, 1) = Chr(10) Then Texte = Right(Texte, Len(Texte) - 1)
        If Right(Texte, 1) = Chr(10) Then Texte = Left(Texte, Len(Texte) - 1)
        Do Until InStr(1, Texte, Chr(10) & Chr(10)) = 0
            Texte = Replace(Texte, Chr(10) & Chr(10), Chr(10))
        Loop
        Cell.Offset(1, 0).Value = Texte
    Next
End Sub

Sub copy_Texte_Dessous_Sans_Barre3()
Dim Cell As Range, i As Long, Texte As String
    
    For Each Cell In Range(Range("B2:C2").Address)
        Texte = ""
        For i = 1 To Len(Cell)
          With Cell.Characters(Start:=i, Length:=1).Font
            
                If Cell.Characters(Start:=i, Length:=1).Text = Chr(10) Or _
                    (.Underline = xlUnderlineStyleNone And _
                        (.ColorIndex = 1 Or .ColorIndex = xlAutomatic)) Then
                    Texte = Texte & Mid(Cell.Value, i, 1)
           End If
          End With
        Next
        Do Until InStr(1, Texte, Chr(10) & Chr(10)) = 0
            Texte = Replace(Texte, Chr(10) & Chr(10), Chr(10))
        Loop
        If Left(Texte, 1) = Chr(10) Then Texte = Right(Texte, Len(Texte) - 1)
        If Right(Texte, 1) = Chr(10) Then Texte = Left(Texte, Len(Texte) - 1)
        Cell.Offset(1, 0).Value = Texte
    Next
End Sub