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

D

Deliau

XLDnaute Nouveau
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
 
Trier par date Trier par votes
J

jmfmarques

XLDnaute Accro
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)
 
Dernière édition:
Vote positif 0 Vote négatif
sylvanu

sylvanu

XLDnaute Barbatruc
Supporter XLD
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
 

Pièces jointes

  • exemple2.xls
    67.5 KB · Affichages: 4
Vote positif 0 Vote négatif
sylvanu

sylvanu

XLDnaute Barbatruc
Supporter XLD
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.
 

Pièces jointes

  • exemple3.xls
    68.5 KB · Affichages: 3
Dernière édition:
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
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+
 
Dernière édition:
Vote positif 0 Vote négatif
laurent950

laurent950

XLDnaute Accro
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
 
Dernière édition:
Vote positif 0 Vote négatif
laurent950

laurent950

XLDnaute Accro
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
 

Pièces jointes

  • ModifChaineComplexeV2.xls
    64 KB · Affichages: 3
Dernière édition:
Vote positif 0 Vote négatif
J

jmfmarques

XLDnaute Accro
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)
 
Dernière édition:
Vote positif 0 Vote négatif
patricktoulon

patricktoulon

XLDnaute Barbatruc
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
 
Dernière édition:
Vote positif 0 Vote négatif

Discussions similaires

M
  • Question
XL 2016 Trier chaine de caractères dans une cellule
2
Réponses
20
Affichages
423
patricktoulon
patricktoulon
chaelie2015
  • Résolu(e)
XL 2013 (RESOLU) Affichage des résultats dans un tableau selon des conditions
Réponses
13
Affichages
298
chaelie2015
chaelie2015
M
  • Question
XL 2010 Comment alimenter automatiquement des cellules à partir d'une ligne sélectionnée dans un tableau?
Réponses
13
Affichages
557
ManuXZ
M
chaelie2015
  • Résolu(e)
Autres (RESOLU)Restituer la première lettre de chaque mot dans une chaine(Formule)
Réponses
6
Affichages
2 K
job75
job75
C
  • Résolu(e)
Microsoft 365 Créer un RV outlook à partir de chaque ligne d'un tableau
Réponses
8
Affichages
737
c.branco
C
S
  • Résolu(e)
XL 2019 Modifier formule à l'insertion de ligne dans un tableau
Réponses
3
Affichages
273
ST4423
S
A
  • Résolu(e)
Microsoft 365 Copier la même cellule de plusieurs onglets dans différentes colonnes
2
Réponses
23
Affichages
827
AlexiaC
A
A
  • Question
XL 2016 stocker mes données dans une variable à partir d'un tableau en VBA
Réponses
2
Affichages
345
Staple1600
Staple1600
G
  • Question
Microsoft 365 Saut de ligne dans une cellule
Réponses
3
Affichages
139
GClaire
G
B
  • Question
XL 2016 Macro pour identifier un texte dans un tableau et appliquer une modification sur une cellule sur la même ligne
Réponses
5
Affichages
250
ChTi160
ChTi160

Membres actuellement en ligne

2 membres et 29 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
312 206
Messages
2 086 219
Membres
103 158
dernier inscrit
laufin