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

[MJ13]

Bonjour à tous

Je cherche le moyen en VBA de copier des textes en dessous sans les textes soulignées ou de couleur.

La, je cale, en VBA, c'est pas simple (voir le fichier)😕.

Merci d'avance 🙂

 

[denisbouchard]

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

Bonjour à tous

Je cherche le moyen en VBA de copier des textes en dessous sans les textes soulignées ou de couleur.

La, je cale, en VBA, c'est pas simple (voir le fichier)😕.


Merci d'avance 🙂

Salut MJ13 et le forum,
d'après ce que je comprends, tu veux copier une cellule et la coller dans une autre vierge, mais sans fioriture. C'est c'est bien cela voici une petite routine.
Range("ta cellule a copier").Select
Selection.Copy
Range("ta cellule de destination").Select
ActiveSheet.Paste
Range("une cellule vierge").Select
Selection.Copy
Range("C12").Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Range("E14").Select
Je suis, aussi, sous Excel 2007, ça marche très bien.
Bon courage
denis

 

[tototiti2008]

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

Bonjour Michel, Bonjour Denis,

peut-être

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

Restera peut-être à supprimer les retour lignes éventuels (chr(10)) en début et fin de résultat

Edit : pour ça, ajoutes

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)

juste avant

Cell.Offset(1, 0).Value = Texte

 

[MJ13]

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

Bonjour Denis, Totottiti

Merci beaucoup pour votre retour 😉.

La formule de Tototiti marche très bien, celle de Denis, je l’adapterai demain pour voir 😱.

Bonne soirée 🙂.

 

[denisbouchard]

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

Bonjour Michel, Bonjour Denis,

peut-être

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

Restera peut-être à supprimer les retour lignes éventuels (chr(10)) en début et fin de résultat

Edit : pour ça, ajoutes

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)

juste avant

Bonjour, tototit2008
Ca marche aussi si la cellule à du texte et des chiffres?

 

[tototiti2008]

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

Bonjour Denis, Bonjour Michel,

Ca marche aussi si la cellule à du texte et des chiffres?

Euh oui, pourquoi ? Chaque caractère souligné ou en couleur est ignoré, quel qu'il soit

maintenant je n'ai pas testé avec des cellules contenant des nombres purs, peut-être pas trop fonctionnel dans ce cas, à tester

 

[MJ13]

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

Bonjour Tototiti, Denis

Après test, la solution de Denis n'est aps vraiment celle que je recherche.

Avce la solution de TototTiti, c'est bien mais je voudrais garder le chr(10) si j'ai 2 textes qui se suivent (voir fichier joint), mais la je patauge 😕

Merci d'avance 🙂.

 

[tototiti2008]

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

Re,

Peut-être ?

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

 

[MJ13]

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

Re Tototiti

Ah, on avance, "petit à petit, Titi fait son nid" 😱.

C'est presque cela mais pour la seconde cellule, il faudrait garder les Chr(10) du milieu, j'espère que c'est pas trop compliqué 😕.

Encore merci pour ta persévérance 🙂.

 

[tototiti2008]

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

Re,

Petit à petit, toto fait son rot ? désolé 😱

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

 

[MJ13]

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

Re Tototiti

Alors la, on tient le bon bout 😱.

Merci pour tes solutions miraculeuses 🙂

Voici le fichier avec tes solutions, c'est très formateur 😱.

 

[MJ13]

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

Re Bonjour à tous

Pour clore cette discussion, je me sis dit:"Et si je veux rajouter des condiitons", j'ai donc ajouter 2 conditions sur les textes barrés. Bon c'est vrai, que c'est assez complexe entre les or et les and 😱.

Encore merci Tototiti et bonne journée à tous🙂