XL 2016 Modifier une chaine complexe dans chaque cellule d'un tableau

Deliau · 21 Mars 2020

Bonjour,

Je dispose d'un tableau de plusieurs milliers de lignes et de dizaines de colonnes.
Dans certaines de ces cellules, je souhaite remplacer la chaine "aXb-cXd" par "aXb-c", ou a, b, c et d sont des nombres entiers < 1000 et X une seule lettre.
Le fait qu'il y ait deux fois la lettre X me bloque dans ma macro.

Comment enlever de chaque cellule la fin de la chaine "Xd", sachant que d'autres cellules n'ont pas ce format ? Je sèche ..

Merci,
Lucie

sylvanu · 21 Mars 2020

Bonjour Deliau,
Sans un petit fichier exemple, les réponses seront évasives et surement à coté de la plaque tellement le nombre de configurations possibles est grand.

Juste quelques cellules représentatives suffiront.

jmfmarques · 21 Mars 2020

Bonjour Deliau
Est-ce ceci, que tu cherches :

VB:

chaine = "124A23-2Y345"
toto = StrReverse(chaine)
Do While toto Like "[0-9]*"
  toto = Mid(toto, 2)
Loop
MsgBox "la chaine " & chaine & vbCrLf & "devient : " & vbCrLf & StrReverse(Mid(toto, 2))

Une solution parmi d'autres possibles. J'ai choisi celle-ci par jeu.

EDIT en voilà une seconde, non moins savoureuse (en raison de ce que j'y mets dans la clause else)

VB:

chaine = "124A23-2Y345"
For k = Len(toto) To 1 Step -1
  If IsNumeric(Mid(toto, k, 1)) Then Mid(toto, k, 1) = " " Else Mid(toto, k, 1) = " ": Exit For
Next
MsgBox Trim(toto)

Deliau · 21 Mars 2020

sylvanu à dit:
Bonjour Deliau,
Sans un petit fichier exemple, les réponses seront évasives et surement à coté de la plaque tellement le nombre de configurations possibles est grand.
Juste quelques cellules représentatives suffiront.

Voici :

sylvanu · 21 Mars 2020

Re,
En PJ un essai.
J'ai supposé que la matrice commençait en A1, sinon reprendre code :

VB:

Sub Test()
For Each c In ActiveSheet.[A1].CurrentRegion
    If IsNumeric(Left(c, 1)) Then
        tablo = Split(c, "-")
        Chaine = tablo(0) & "-"
        For i = 1 To Len(tablo(1))
            If IsNumeric(Mid(tablo(1), i, 1)) Then
                Chaine = Chaine & Mid(tablo(1), i, 1)
            Else
                c.Value = Chaine
            End If
        Next i
    End If
Next
End Sub

sylvanu · 21 Mars 2020

Re,
Avec plusieurs milliers de lignes et de dizaines de colonnes, il faut passer par des arrays pour être plus rapide. ( 0.7s pour un tableau de 2300 lignes et 64 colonnes ) Voir PJ.

VB:

Sub Test()
Matrice = ActiveSheet.[A1].CurrentRegion
X = UBound(Matrice, 1)
Y = UBound(Matrice, 2)
For Lig = 1 To X
    For Col = 1 To Y
        c = Matrice(Lig, Col)
        If IsNumeric(Left(c, 1)) Then
            tablo = Split(c, "-")
            Chaine = tablo(0) & "-"
            For i = 1 To Len(tablo(1))
                If IsNumeric(Mid(tablo(1), i, 1)) Then
                    Chaine = Chaine & Mid(tablo(1), i, 1)
                Else
                    Matrice(Lig, Col) = Chaine
                End If
            Next i
        End If
    Next
Next
ActiveSheet.[A1].CurrentRegion = Matrice
End Sub

Changez les deux [A1] suivant la place de vos données.

Deliau · 21 Mars 2020

Merci sylvanu, jmfmarques,

Je vais analyser et comprendre vos codes.

job75 · 21 Mars 2020

Bonjour Deliau, sylvanu, jmfmarque,

Joli problème.

D'après ce qui est dit au post #1 il faut vérifier que les coefficients a b c d sont inférieurs à 1000 :

VB:

Sub Remplacer()
'chaîne aXb-cXd avec a b c d nombres entiers < 1000 et X une lettre unique
Dim tablo, ncol%, i&, j%, t, pmoins%, k%, lettre$, x$, p1%, p2%
With ActiveSheet.UsedRange
    tablo = .Formula 'matrice, plus rapide
    If Not IsArray(tablo) Then tablo = .Resize(2).Formula 'au moins 2 éléments
    ncol = UBound(tablo, 2)
    For i = 1 To UBound(tablo)
        For j = 1 To ncol
            t = tablo(i, j)
            pmoins = InStr(t, "-") 'position du signe -
            If pmoins Then
                p1 = 0: p2 = 0
                For k = 1 To Len(t)
                    lettre = Mid(t, k, 1)
                    If UCase(lettre) Like "[A-Z]" Then
                        If p1 = 0 Then
                            '---coef a---
                            x = Left(t, k - 1)
                            If Not IsNumeric(x) Then Exit For
                            If CDbl(x) <> Int(x) Or Val(x) > 999 Then Exit For
                            '---coef b---
                            x = Mid(t, k + 1, pmoins - k - 1)
                            If Not IsNumeric(x) Then Exit For
                            If CDbl(x) <> Int(x) Or Val(x) > 999 Then Exit For
                            p1 = k 'mémorise
                        Else
                            If lettre <> Mid(t, p1, 1) Then Exit For 'il faut la même lettre, casse respectée
                            '---coef c---
                            x = Mid(t, pmoins + 1, k - pmoins - 1)
                            If Not IsNumeric(x) Then Exit For
                            If CDbl(x) <> Int(x) Or Val(x) > 999 Then Exit For
                            '---coef d---
                            x = Mid(t, k + 1)
                            If Not IsNumeric(x) Then Exit For
                            If CDbl(x) <> Int(x) Or Val(x) > 999 Then Exit For
                            p2 = k 'mémorise
                            Exit For 'ajouté pour réduire la durée d'exécution
                        End If
                    End If
                Next k
                If p2 Then tablo(i, j) = Left(t, p2 - 1) 'modification du tableaau
            End If
    Next j, i
    '---restitution---
    .Formula = tablo
End With
End Sub

Edit : ajouté un Exit For pour réduire la durée d'exécution.

A+

laurent950 · 21 Mars 2020

Bonsoir Deliau, sylvanus,jmfmarques, job75

En réponse a votre problématique :
* Le fait qu'il y ait deux fois la lettre X me bloque dans ma macro.
Voici le code ci-dessous / Sans aucune restriction ModifChaineComplexeV0

VB:

Option Explicit
Sub ModifChaineComplexeV0()
' ***********************************************************
' Sans restriction
' ***********************************************************
Dim Pattern As String
Dim Reg As Object
    Set Reg = CreateObject("vbscript.regexp")
Dim Match As Object
Dim Matches As Object
' ***********************************************************
Dim Factiv As Worksheet
    Set Factiv = Worksheets(ActiveSheet.Name)
Dim TabMot As Variant
' La matrice cellule A19:D24 (A adapter Ci-dessous)
    TabMot = Factiv.Range(Factiv.Cells(19, 1), Factiv.Cells(24, 4))
Dim i As Long, j As Long
' ***********************************************************
For i = LBound(TabMot, 1) To UBound(TabMot, 1)
    For j = LBound(TabMot, 2) To UBound(TabMot, 2)
        If TabMot(i, j) Like "*-*" Then
        With Reg
            .Pattern = "[a-zA-Z]"
            .MultiLine = True: .IgnoreCase = True: .Global = True:  'MsgBox .Test(TabMot(i, j))
                If .Test(TabMot(i, j)) = True Then
                    Set Matches = .Execute(TabMot(i, j))
                        For Each Match In Matches
                            If Matches.Count = 2 Then
                            ' ModifChaineComplexe
                                TabMot(i, j) = Replace(TabMot(i, j), Match.Value & Split(TabMot(i, j), Match.Value)(Matches.Count), " ")
                            ' Operation terminé
                                Exit For
                            Else
                            ' si la chaine numérique ne contient pas exclusivement 2 caractéres alphabétiques
                                Exit For
                            End If
                        Next Match
                    End If
        End With
        End If
    Next j
Next i
' Resultat : A adapter pour l'endroit ou cela doit etre restitué
    Factiv.Cells(19, 6).Resize(UBound(TabMot, 1), UBound(TabMot, 2)) = TabMot
End Sub

cdt
Laurent

laurent950 · 21 Mars 2020

J'ai pas tous compris du poste #1
Modification avec prise en compte de la restriction : ModifChaineComplexeV1
ps : Precision pour Confirmer ci-dessous :
' Supérieur à 1 000
' 364S99-42S7100 -------->>> Resultat inchangé ! = 364S99-42S7100
' condition ajouté au traitement
' Avec restriction / aXb-cXd" par "aXb-c700"
' If Split(TabMot(i, j), Match.Value)(Matches.Count) < 1000 Then
' Inférieur à 1 000
' 364S99-42S710 -------->>> Nouveau Resultat = 364S99-42

VB:

Option Explicit
Sub ModifChaineComplexeV1()
' ***********************************************************
' Avec restriction
' si coefficients a b c d sont inférieurs à 1000 :
' "aXb-cXd" par "aXb-c", ou a, b, c et d sont des nombres entiers < 1000 et X une seule lettre.
' que se passe t'il si
' 364S99-42S7100 -------- Resultat = 364S99-42S7100
' ***********************************************************
Dim Pattern As String
Dim Reg As Object
    Set Reg = CreateObject("vbscript.regexp")
Dim Match As Object
Dim Matches As Object
' ***********************************************************
Dim Factiv As Worksheet
    Set Factiv = Worksheets(ActiveSheet.Name)
Dim TabMot As Variant
' La matrice cellule A19:D24 (A adapter Ci-dessous)
    TabMot = Factiv.Range(Factiv.Cells(19, 1), Factiv.Cells(24, 4))
Dim i As Long, j As Long
' ***********************************************************
For i = LBound(TabMot, 1) To UBound(TabMot, 1)
    For j = LBound(TabMot, 2) To UBound(TabMot, 2)
        If TabMot(i, j) Like "*-*" Then
        With Reg
            .Pattern = "[a-zA-Z]"
            .MultiLine = True: .IgnoreCase = True: .Global = True:  'MsgBox .Test(TabMot(i, j))
                If .Test(TabMot(i, j)) = True Then
                    Set Matches = .Execute(TabMot(i, j))
                        For Each Match In Matches
                            If Matches.Count = 2 Then
                            ' Avec restriction
                                If Split(TabMot(i, j), Match.Value)(Matches.Count) < 1000 Then
                                    ' ModifChaineComplexe
                                        TabMot(i, j) = Replace(TabMot(i, j), Match.Value & Split(TabMot(i, j), Match.Value)(Matches.Count), " ")
                                    ' Operation terminé
                                        Exit For
                                End If
                            Else
                            ' si la chaine numérique ne contient pas exclusivement 2 caractéres alphabétiques
                                Exit For
                            End If
                        Next Match
                    End If
        End With
        End If
    Next j
Next i
' Resultat : A adapter pour l'endroit ou cela doit etre restitué
    Factiv.Cells(19, 6).Resize(UBound(TabMot, 1), UBound(TabMot, 2)) = TabMot
End Sub

Pour Info, J'ai garder mon travail en Mémoir ici
Modification et sauvegarde de cette regex interressante corrigé par PatrickToulon
La Solution FINAL EST EN POSTE #15 PATRICKTOULON
MERCI PATRICK

VB:

Option Explicit
Sub ModifChaineComplexeV2()
' ***********************************************************
 ' Sans restriction
' ***********************************************************
Dim Pattern As String
Dim Reg As Object
    Set Reg = CreateObject("vbscript.regexp")
Dim Match As Object
Dim Matches As Object
' ***********************************************************
Dim Factiv As Worksheet
    Set Factiv = Worksheets(ActiveSheet.Name)
Dim TabMot As Variant
' La matrice cellule A19:D24 (A adapter Ci-dessous)
    TabMot = Factiv.Range(Factiv.Cells(19, 1), Factiv.Cells(24, 4))
Dim i As Long, j As Long
' ***********************************************************
For i = LBound(TabMot, 1) To UBound(TabMot, 1)
    For j = LBound(TabMot, 2) To UBound(TabMot, 2)
        With Reg
            .Pattern = "(\d{1,3})[A-z](\d{1,3})-(\d{1,3})[A-z](\d{1,3})$"
            .MultiLine = True: .IgnoreCase = True: .Global = True:  'MsgBox .Test(TabMot(i, j))
                If .test(TabMot(i, j)) = True Then
                    Set Matches = .Execute(TabMot(i, j))
                        .Pattern = "(\d{1,3})[A-z](\d{1,3})-(\d{1,3})"
                            Set Matches = .Execute(TabMot(i, j))
                                TabMot(i, j) = Matches(0).Value
                End If
        End With
    Next j
Next i
' Resultat : A adapter pour l'endroit ou cela doit etre restitué
    Factiv.Cells(19, 6).Resize(UBound(TabMot, 1), UBound(TabMot, 2)) = TabMot
End Sub

Laurent

jmfmarques · 21 Mars 2020

RE
Je crois deviner (à travers les bouts de code écrits par ceux qui ont ouvert le classeur), que :
- toutes les données n'ont pas forcément le format des données à traiter

il ne faut dans ces conditions traiter que celles concernées. Dans ces conditions, c'est tout le format, qu'il convient de vérifier !

voici la fonction que je propose à cet effet :

VB:

Public Function verif_format(c As String) As Boolean
   t = Split(c, "-")
   verif_format = True
   If UBound(t) <> 1 Then verif_format = False: Exit Function
   For k = 0 To 1
     If Val(t(k)) < 1 Or Val(t(k)) > 999 Or Val(StrReverse(t(k))) < 1 Or Val(StrReverse(t(k))) > 999 Then
       verif_format = False: Exit Function
     End If
     If t(k) Like "*[A-Z]*[A-Z]*" Then verif_format = False: Exit Function
   Next
End Function

et ne traiter (l'un de mes deux codes plus haut) que si cette fonction retourne TRUE

EDIT : je viens de rajouter un autre garde-fou dans cette fonction (une seule lettre par portion du split)

laurent950 · 21 Mars 2020

Bonsoir jmfmarques
Avec la fonction ci dessus si c contient "364S99-42S710"
qu'elle resultat est renvoyé dans verif_format
J'obtien rien de mon côté vide ?

jmfmarques · 21 Mars 2020

Bonsoir Laurent

VB:

Dim toto As String
  toto = "364S99-42S710"
  MsgBox verif_format(toto)

me retourne VRAI
Je me demande comment tu peux avoir un "" (vide) alors que la fonction est typée en booléen ...!

laurent950 · 21 Mars 2020

D'accord j'ai compris merci jmfmarques
et de ton côté tu as compris la mienne la version ModifChaineComplexeV1 ?

patricktoulon · 21 Mars 2020

bonsoir a tous
testé sur le fichier #post 2

VB:

Sub test12(cel As Range)
    Dim maVar As String, matchs
    maVar = cel.Value
    With CreateObject("VBScript.RegExp"):
          .Global = True: .IgnoreCase = True: .Pattern = "(\d{1,3})[A-z](\d{1,3})-(\d{1,3})[A-z](\d{1,3})$"
        Set matchs = .Execute(maVar)
        If matchs.Count > 0 Then
            maVar = matchs(0)
            .Pattern = "(\d{1,3})[A-z](\d{1,3})-(\d{1,3})"
            Set matchs = .Execute(maVar)
            maVar = matchs(0)
            MsgBox cel.Address & "--->" & maVar
        End If
    End With
End Sub

Sub test()
    Dim cel As Range
    For Each cel In Range("A1:d6").Cells
        test12 cel
    Next
End Sub

il est bien évident que les sous chaîne numérique au dessus de 999
ne passeront pas par les "(\d{1,3})" je m’embête même pas a tester
le principe est simple
je teste le pattern de format de chaîne complète sur la valeur
et le format réduit sur le matchts(0) qui du même coup me donne la chaîne réduite

XL 2016 Modifier une chaine complexe dans chaque cellule d'un tableau

XLDnaute Nouveau

XLDnaute Barbatruc

XLDnaute Accro

XLDnaute Nouveau

Pièces jointes

XLDnaute Barbatruc

Pièces jointes

XLDnaute Barbatruc

Pièces jointes

XLDnaute Nouveau

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Barbatruc

Pièces jointes

XLDnaute Accro

XLDnaute Barbatruc

XLDnaute Accro

XLDnaute Barbatruc

XLDnaute Barbatruc

Discussions similaires

Partager cette page

Statistiques des forums