Fonction Rechercher/Remplacer dans une cellule avec plusieurs formats

Bonjour tout le monde,

Je suis un petit nouveau mais je consulte ce forum de façon régulière au grès de mes difficultés rencontrées sur Excel.

D'habitude je trouve toujours un sujet déjà ouvert qui m'aide pour résoudre mon problème mais pas ce coup-ci.

Je souhaite utiliser la fonction Recherche / remplacer dans une cellule (en fait beaucoup plus qu'une cellule), sur environ 2000 fichier Excel qui contienne entre 2 et 50 cellules à modifier.

Voici le texte de la cellule à modifier : ⊔⊔h⊔⊔ ⊔⊔.⊔⊔⊔.201⊔

(et la vous voyez le problème, nous ne somme plus en 201⊔ mais en 202⊔

Le problème c'est la différence de type/taille de police.

Si je vais une fonction recherche / remplacer le texte vas passer de :

⊔⊔h⊔⊔ ⊔⊔.⊔⊔⊔.201⊔

à

⊔⊔h⊔⊔ ⊔⊔.⊔⊔⊔.202⊔

Or le format est très important pour moi.

D'ou la question, comment faire pour modifier .201⊔ en.202⊔ (ou en.20⊔⊔ Sans perdre le format original.

D'avance merci de votre aide

Bonjour et bienvenue,

Les cellules sont-elles au format texte ?

As-tu un fichier exemple ?

Bonjour,

les cellules sont au format ''Général''

En gros j'ai environ 1000 classeurs qui contiennent tous un onglet recette

ou j'ai ces cellules que je souhaite passer de 201⊔ à 202⊔ (ou 20⊔⊔)

ces onglets sont imprimés pour être ensuite emmargé sous forme de formulaire

(j'ai essaye de mettre un fichier joint mais : Vous ne pouvez pas ajouter de lien externe au site avant d'avoir atteint le minimum de 10 messages (retirez le lien "xxx" pour continuer).

)

okctrash a écrit :

j'ai essaye de mettre un fichier joint mais : Vous ne pouvez pas ajouter de lien externe au site

mais tu peux joindre un fichier (simplifié)

Voir Bouton Ajouter un fichier

Bonjour,

Par macro, voici un exemple (pas rapide) qui conserve les couleurs.

Il est possible d'adapter pour conserver le type, la taille des polices.$

A tester :

Option Explicit

Private Const VALEUR_CHERCHEE As Variant = 201
Private Const VALEUR_DE_REMPLACEMENT As Variant = 202

Public Sub Remplacer()
Dim c As Range, firstAddress As String
    With Worksheets("Feuil1")
        Set c = .Cells.Find(VALEUR_CHERCHEE, LookIn:=xlValues, LookAt:=xlPart)
        If Not c Is Nothing Then
            firstAddress = c.Address
            Remplace c, VALEUR_DE_REMPLACEMENT, VALEUR_CHERCHEE
            Do
                Set c = .Cells.Find(VALEUR_CHERCHEE, LookIn:=xlValues, LookAt:=xlPart)
                If c Is Nothing Then
                    GoTo DoneFinding
                Else
                    Remplace c, VALEUR_DE_REMPLACEMENT, VALEUR_CHERCHEE
                End If
            Loop While c.Address <> firstAddress
        End If
DoneFinding:
    End With
End Sub

Private Sub Remplace(R As Range, Valeur As Variant, Cherche As Variant)
Dim i As Integer, Couls() As Integer
    i = InStr(R.Value, Cherche)
    Couls = Couleurs(R)
    R.Value = Replace(R.Value, Cherche, Valeur)
    Retablit R, Couls
End Sub

Private Function Couleurs(R As Range) As Integer()
ReDim v(1 To Len(R.Value)) As Integer
Dim i As Integer, L As Integer
    L = Len(R.Value)
    For i = 1 To L
        v(i) = R.Characters(i, 1).Font.ColorIndex
    Next
    Couleurs = v
    Erase v
End Function

Private Sub Retablit(R As Range, c() As Integer)
Dim i As Integer, L As Integer
    L = Len(R.Value)
    For i = 1 To L
        R.Characters(i, 1).Font.ColorIndex = c(i)
    Next
End Sub

pijaku a écrit :

Bonjour,

Par macro, voici un exemple (pas rapide) qui conserve les couleurs.

Il est possible d'adapter pour conserver le type, la taille des polices.$

Bravo pijaku

Rien ne dit que la couleur n'était pas juste pour exprimer ici le besoin !

Beau travail...

Salut Steelson,

Beau travail...

Merci de ton appréciation. Rien que pour ça, voici la même mais avec traitement de :

> couleur,

> nom de police,

> taille,

> gras,

> italique,

> souligné...

What Else?

Option Explicit

Private Const VALEUR_CHERCHEE As Variant = 201
Private Const VALEUR_DE_REMPLACEMENT As Variant = 202
Private Const NOM_FEUILLE As String = "Feuil1"

Public Sub Remplacer()
Dim C As Range, firstAddress As String
    With Worksheets(NOM_FEUILLE)
        Set C = .Cells.Find(VALEUR_CHERCHEE, LookIn:=xlValues, LookAt:=xlPart)
        If Not C Is Nothing Then
            firstAddress = C.Address
            Remplace C, VALEUR_DE_REMPLACEMENT, VALEUR_CHERCHEE
            Do
                Set C = .Cells.Find(VALEUR_CHERCHEE, LookIn:=xlValues, LookAt:=xlPart)
                If C Is Nothing Then
                    GoTo DoneFinding
                Else
                    Remplace C, VALEUR_DE_REMPLACEMENT, VALEUR_CHERCHEE
                End If
            Loop While C.Address <> firstAddress
        End If
DoneFinding:
    End With
End Sub

Private Sub Remplace(R As Range, Valeur As Variant, Cherche As Variant)
Dim i As Integer, C() As Variant
    i = InStr(R.Value, Cherche)
    C = Datas(R)
    R.Value = Replace(R.Value, Cherche, Valeur)
    Retablit R, C
End Sub

Private Function Datas(R As Range) As Variant()
ReDim v(1 To Len(R.Value), 1 To 6) As Variant
Dim i As Integer, L As Integer
    L = Len(R.Value)
    For i = 1 To L
        v(i, 1) = R.Characters(i, 1).Font.ColorIndex
        v(i, 2) = R.Characters(i, 1).Font.Name
        v(i, 3) = R.Characters(i, 1).Font.Size
        v(i, 4) = R.Characters(i, 1).Font.Bold
        v(i, 5) = R.Characters(i, 1).Font.Italic
        v(i, 6) = R.Characters(i, 1).Font.Underline
    Next
    Datas = v
    Erase v
End Function

Private Sub Retablit(R As Range, C() As Variant)
Dim i As Integer, L As Integer
    L = Len(R.Value)
    For i = 1 To L
        R.Characters(i, 1).Font.ColorIndex = C(i, 1)
        R.Characters(i, 1).Font.Name = C(i, 2)
        R.Characters(i, 1).Font.Size = C(i, 3)
        R.Characters(i, 1).Font.Bold = C(i, 4)
        R.Characters(i, 1).Font.Italic = C(i, 5)
        R.Characters(i, 1).Font.Underline = C(i, 6)
    Next
End Sub

Une proposition un peu plus longue

Sub Changer201en202()
    ActiveSheet.UsedRange.Replace What:="201", Replacement:="202", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
End Sub

@Steelson,

Ta proposition, chez moi, remplace le formatage (couleur des caractères).

pijaku a écrit :

Ta proposition, chez moi, remplace le formatage (couleur des caractères).

Bonsoir tout le monde,

Tout d'abord merci à tous de vos réponses / propositions @Steelson et @pijaku !!

je regarde vos messages à tête reposée pour tester (désolé, j'ai un peu posé le poste et je suis parti faire autre chose ^^)

je vais voir pour vos poster le fichier exemple que j'ai préparé (sur mon autre PC…)

OkC

(re)Bonjour,

Voici un fichier exemple à modifier

(PS : je n'ai pas encore pu tester vos solutions mais aujourd'hui promis je test...)

voici au plus simple

Sub Changer201en202()
    ActiveSheet.UsedRange.Replace What:="201", Replacement:="202", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
End Sub

mais pour conserver ta mise en forme un peu particulière (intérêt ?) vois avec pijaku

Bonjour Steelson

et merci pour ta proposition (qui fonctionne mais ne garde pas le format de la cellule)

l'intérêt d'avoir une partie en gris : c'est qu'une personne imprime le document le complète à la main en respectant les cases. (et en restant lisible)

l'interêt de la partie en noire… est … en fait elle n'a pas d'intérêt autre que d'être lisible malgré l'écriture manuscrite à côté

et puis c'est pour le challenge sinon ce n'est pas drôle

Bonjour,

cf mon envoi du 09 mars 2020, 10:43

Bonjour,

Pijaku, je viens de tester et c’est parfait cela fonctionne nickel 👍🏽

Il me reste maintenant à ajouter une macro pour pouvoir le faire automatiquement sur tous les documents contenu dans un dossier et vous m’aurez retirer une belle petite aiguille du pied 🦶

okctrash a écrit :

Il me reste maintenant à ajouter une macro pour pouvoir le faire automatiquement sur tous les documents contenu dans un dossier et vous m’aurez retirer une belle petite aiguille du pied 🦶

Voit ceci (à adapter) :

Sub BoucleDir()
Dim Chemin As String, Fichier As String, Extens As String
    Chemin = "C:\Users\" & Environ("UserName") & "\Desktop\"  '**** A ADAPTER ***
    Extens = "*.xls*"
    Fichier = Dir(Chemin & Extens)
    If Fichier <> vbNullString Then
        Do
            Workbooks.Open Chemin & Fichier
            'ton traitement ici
            Workbooks(Fichier).Close True            
            Fichier = Dir
        Loop While Fichier <> vbNullString
    End If
End Sub

Salut Pijaku, quelle rapidité,

le code est beau.

j'ai une question concernant l'endroit ou je met mon traitement :

" 'ton traitement ici"

Je pensais qu'il suffisait juste de mettre : ''Remplacer'' qui est le nom de la macro (dans le même module)

Mais cela ne fait rien.

Est ce moi qui fait mal ?

Sinon je vois que le code fait :

            Workbooks.Open Chemin & Fichier --> Ouvrir le fichier ?
            'ton traitement ici --> traitement 
            Workbooks(Fichier).Close True    --> fermer le fichier

Il n'y a pas besoin de ligne pour sauvegarder le fichier aprés le traitement ?

Encore merci de t'occuper si bien de mon cas

NB : ce que j'ai mis pour tester :

'macro a exectuer pour executer une macro dans X fichier
Sub BoucleDir()
Dim Chemin As String, Fichier As String, Extens As String

    Chemin = "d:\Users\cestmoi\Desktop\Test recettes à modifier"
    Extens = "*.xls*"

    Fichier = Dir(Chemin & Extens)
    If Fichier <> vbNullString Then
        Do
            Workbooks.Open Chemin & Fichier
            'ici la macro a exectuer
            Remplacer
            'Workbooks(Fichier).Close True
            Fichier = Dir
        Loop While Fichier <> vbNullString
    End If
End Sub

Non, tu n'as rien fait de mal.

Dans la Sub Remplacer, il n'est pas fait mention du classeur concerné.

Or, en ouvrant d'autres classeurs, je penses que la macro ne sait plus trop lequel traiter.

Disons le lui alors :

Option Explicit

Private Const VALEUR_CHERCHEE As Variant = 201
Private Const VALEUR_DE_REMPLACEMENT As Variant = 202
Private Const NOM_FEUILLE As String = "Feuil1"

Public Sub BoucleDir()
Dim Wb As Workbook, Chemin As String, Fichier As String, Extens As String
    Chemin = "C:\Users\" & Environ("UserName") & "\Desktop\"  '**** A ADAPTER ***
    Extens = "*.xls*"
    Fichier = Dir(Chemin & Extens)
    If Fichier <> vbNullString Then
        Do
            Set Wb = Workbooks.Open(Chemin & Fichier)
            Remplacer Wb
            Wb.Close True
            Fichier = Dir
        Loop While Fichier <> vbNullString
    End If
End Sub

Private Sub Remplacer(W As Workbook)
Dim C As Range, firstAddress As String
    With W.Worksheets(NOM_FEUILLE)
        Set C = .Cells.Find(VALEUR_CHERCHEE, LookIn:=xlValues, LookAt:=xlPart)
        If Not C Is Nothing Then
            firstAddress = C.Address
            Remplace C, VALEUR_DE_REMPLACEMENT, VALEUR_CHERCHEE
            Do
                Set C = .Cells.Find(VALEUR_CHERCHEE, LookIn:=xlValues, LookAt:=xlPart)
                If C Is Nothing Then
                    GoTo DoneFinding
                Else
                    Remplace C, VALEUR_DE_REMPLACEMENT, VALEUR_CHERCHEE
                End If
            Loop While C.Address <> firstAddress
        End If
DoneFinding:
    End With
End Sub

Private Sub Remplace(R As Range, Valeur As Variant, Cherche As Variant)
Dim i As Integer, C() As Variant
    i = InStr(R.Value, Cherche)
    C = Datas(R)
    R.Value = Replace(R.Value, Cherche, Valeur)
    Retablit R, C
End Sub

Private Function Datas(R As Range) As Variant()
ReDim v(1 To Len(R.Value), 1 To 6) As Variant
Dim i As Integer, L As Integer
    L = Len(R.Value)
    For i = 1 To L
        v(i, 1) = R.Characters(i, 1).Font.ColorIndex
        v(i, 2) = R.Characters(i, 1).Font.Name
        v(i, 3) = R.Characters(i, 1).Font.Size
        v(i, 4) = R.Characters(i, 1).Font.Bold
        v(i, 5) = R.Characters(i, 1).Font.Italic
        v(i, 6) = R.Characters(i, 1).Font.Underline
    Next
    Datas = v
    Erase v
End Function

Private Sub Retablit(R As Range, C() As Variant)
Dim i As Integer, L As Integer
    L = Len(R.Value)
    For i = 1 To L
        R.Characters(i, 1).Font.ColorIndex = C(i, 1)
        R.Characters(i, 1).Font.Name = C(i, 2)
        R.Characters(i, 1).Font.Size = C(i, 3)
        R.Characters(i, 1).Font.Bold = C(i, 4)
        R.Characters(i, 1).Font.Italic = C(i, 5)
        R.Characters(i, 1).Font.Underline = C(i, 6)
    Next
End Sub

Bonjour,

Pikaku, C'est parfait pour moi !

j'ai utilisé ton code

(fait un micro ajustement au niveau de la recherche que j'ai transformé en String pour inclure un '.')

Je passe en résolu.

Merci à vous 2 pour les propositions et surtout votre temps !

pijaku a écrit :

Non, tu n'as rien fait de mal.

Dans la Sub Remplacer, il n'est pas fait mention du classeur concerné.

Or, en ouvrant d'autres classeurs, je penses que la macro ne sait plus trop lequel traiter.

Disons le lui alors :