Microsoft 365 Récupérer des données sur une chaîne de caractères qui respecte un certain formatage

I

ivan27

XLDnaute Occasionnel
Bonsoir à tous,

Pourriez-vous m'aider pour modifier mon code VBA ou me proposer une solution de substitution pour la récupération de données dans un texte ?

En pièce jointe un fichier test. Le but de mon code est de lire une liste composée de quelques milliers de lignes sur la feuille 'BD' et de transférer certaines données sur la feuille 'UM'.

J'ai des difficultés pour récupérer les données souhaitées de la feuille BD de la colonne B.

J'ai mis une ligne pour l'exemple.

Il faut identifier dans le texte les segments 'PAC' qui contiennent 3 valeurs séparées par des signes ':' et reporter les valeurs en question sur la feuille UM, sur les colonnes KLM

Il faut ensuite identifier pour chaque segment 'PAC', son segment 'GID' puis reporter les valeurs du segment 'GID' en colonnes N et O de la feuille UM.

Explications : 30:KGGID++1:EPDIM+PAC+0.8:0.8:0.92:LMPCI+20M
  • Le segment PAC est identifiable dans le texte car il est toujours formaté ainsi : ‘+PAC+’
  • Le segment GID précède le segment PAC. Le plus simple pour identifier les valeurs à récupérer est de rechercher le signe ‘ :’ qui précède le segment PAC. Ensuite il faut récupérer le nombre qui précède ‘ :’ et les 2 caractères qui suivent immédiatement ‘ :’
Dans le fichier test que je vous transmets en pièce jointe, je récupère ceci sur les 2 dernières colonnes :
1 EE
1 EE
1 EE
1 EE

Alors que le résultat attendu est ceci :
1 EP
3 EE
1 KT
1 EE

Merci d’avance pour votre aide.
 

Pièces jointes

  • test.xlsm
    43 KB · Affichages: 13
Solution
RyuAutodidacte
Bonjour @ivan27 ,

En correction du Post#39 :
je remets tous les codes pour la solution finale corrigé.

PS : Si tout est ok ici après vérification, il serait bien de mettre un pouce bleu sur le post marqué résolu et de déplacer le résolu sur ce post (afin de se référer à la bonne version de code pour ceux qui sont intéressé par cette solution)

A ne pas oublier :
Dans le code de la mise à jour de la base BD, mettre le code :
VB: 
Set Coll = Nothing

En début de module :
VB: 
Option Explicit

Public Coll As Collection

La function corrigée (Ajout de la conversion Cstr) :
VB: 
Function GetBordereau(Ref As String)
Dim...
Trier par date Trier par votes
RyuAutodidacte

RyuAutodidacte

XLDnaute Impliqué
Bonjour @ivan27 , @Phil69970 , @laurent950

La version 2 de mon code : Ajout du calcul de la colonne J
VB: 
Option Explicit

Sub GetGidPacTxT()
Dim BD As Worksheet, UM As Worksheet, InitRowUM As Long, LRowBD As Long, x As Long, Txt$, y As Integer, Pos As Integer, PAC$
Dim FindPAC As Integer, Deb As Integer, S, V, gidValue$, gidPart$, P
Dim A As Date, B$, C$, D$, E$, F$, G$, H$, I As Double
Dim sumResult As Double

    SupprimerDonneesUM
   
    Set BD = ThisWorkbook.Sheets("BD")
    Set UM = ThisWorkbook.Sheets("UM")
   
    InitRowUM = 10
    LRowBD = BD.Cells(Rows.Count, 1).End(xlUp).Row
   
'    Application.ScreenUpdating = False
       
    For x = 2 To LRowBD
   
        Txt = BD.Cells(x, "B").Value
   
        FindPAC = InStr(Txt, "+PAC+")
   
        A = BD.Cells(x, "C").Value: B = BD.Cells(x, "A").Value: C = BD.Cells(x, "E").Value: D = BD.Cells(x, "F").Value:  E = BD.Cells(x, "G").Value
        F = BD.Cells(x, "H").Value: G = BD.Cells(x, "I").Value: H = BD.Cells(x, "J").Value: I = BD.Cells(x, "K").Value
       
        If FindPAC = 0 Then
            ReDim V(1 To 1, 1 To 9)
            V(1, 1) = A: V(1, 2) = B: V(1, 3) = C: V(1, 4) = D: V(1, 5) = E: V(1, 6) = F: V(1, 7) = G: V(1, 8) = H: V(1, 9) = I
            UM.Cells(InitRowUM, 1).Resize(UBound(V), UBound(V, 2)).Value = V
            InitRowUM = InitRowUM + 1
        Else
            Deb = InStrRev(Txt, "GID++", FindPAC)
            S = Mid(Txt, Deb)
            S = Split(S, "GID++")
            ReDim V(1 To UBound(S), 1 To 15)
            For y = 1 To UBound(S)
                Pos = InStr(S(y), ":"):     gidValue = Mid(S(y), 1, Pos - 1):       gidPart = Mid(S(y), Pos + 1, 2)
                Pos = InStr(S(y), "+PAC+") + 5:     PAC = Mid(S(y), Pos):       P = Split(PAC, ":")
                ReDim Preserve P(0 To 2)
               
                V(y, 1) = A: V(y, 2) = B: V(y, 3) = C: V(y, 4) = D: V(y, 5) = E: V(y, 6) = F: V(y, 7) = G: V(y, 8) = H: V(y, 9) = I
                V(y, 11) = P(0): V(y, 12) = P(1): V(y, 13) = P(2): V(y, 14) = gidValue: V(y, 15) = gidPart
               
                sumResult = sumResult + Evaluate(P(0) & " * " & P(1) & " * " & P(2) & " * " & gidValue)
            Next
            For y = 1 To UBound(S):      V(y, 10) = sumResult:      Next
            UM.Cells(InitRowUM, 1).Resize(UBound(V), UBound(V, 2)).Value = V
            InitRowUM = InitRowUM + UBound(V)
            sumResult = 0
        End If
       
    Next
   
'    Application.ScreenUpdating = True
   
End Sub


Sub SupprimerDonneesUM()
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets("UM")
   
    With ws
        .Rows("10:" & .Rows.Count).Delete
    End With
End Sub

Merci @laurent950 pour le compliment (Malheureusement, je n'ai pas accès à un PC pour le moment pour tester)
 
Vote positif 0 Vote négatif
laurent950

laurent950

XLDnaute Barbatruc
Ce qui serait intéressant c'est de tester les diverses possibilités pour extraire les chaines de caractères
L'avantage de la Regex c'est que cela est plus simple une fois créer et a modifier pour en extraire les sous chaine directement. Avec 3000 lignes de textes cela peut être intéressant.
ivan27 à dit:
En production la feuille BD compte environ 3000 lignes et le traitement prend environ 4 secondes
Cliquez pour agrandir...

@RyuAutodidacte je vous ai noté l'astuce ci-dessous pour éviter les découpages et autres et tous faire avec la Regex avec les sous chaines entre parenthéses ( )
ici faut Lire cela
VB: 
((10)|(11)9) = ( 9) qui contient un Ou avec le séparateur |
= (( 10) | ( 11)9 ) encapsulé entre parenthése (  9) qui contient (10)|(11)
= ((20|0.98)) c'est comme cela qu'il faut lire
= le resultat sera celui obtenu dans l'encapsulation ( 9)
= Car ((Pas trouvé = "")|(Trouvé = 0.98)
= Alor Item 10 = "" mais l'item 11 = 0.98
et vis versa
= Car ((trouvé = 20)|(pas Trouvé = "")
= Alor Item 10 = 20 mais l'item 11 = ""
et donc le résultat se trouve a la racine de l'encapsulation est des deux soit
Item 9 = Le résultat obtenu (soit du 10 ou du 11)

Les sous chaines sont ranger comme cela :
VB: 
Pattern = "(GID\+\+)(\d{0,})(:)(\w{2})(\w+)(\+PAC\+)((\d?\d\.\d?\d)|(\d?\d)):((\d?\d\.\d?\d)|(\d?\d)):((\d?\d\.\d?\d)|(\d?\d))"
Pattern = "(0)(1)(2)(3)(4)(5)((7)|(8)6):((10)|(11)9):((13)|(14)12)"
Dans l'explorer VBE il faut ajouter 1 car l'Item commence a 1 voir ci-dessous
Pattern = "(1)(2)(3)(4)(5)(6)((8)|(9)7):((11)|(12)10):((14)|(15)13)"

Alors Pour exemple il est maintenant facile de retrouver la sous chaine : avec l'indice 9 soit Item 10 en lecture direct avec VBE
wsUM.Cells(wsUM.Cells(1048576, "L").End(xlUp).Row + 1, "L").Value = Match.SubMatches.Item(9)

Pour Conclure :
Lorsqu'une alternative (expr1 | expr2) est incluse dans un modèle de recherche régulière et qu'elle est encapsulée dans des parenthèses, elle génère des items supplémentaires dans les sous-chaines renvoyées par SubMatches.
Ces items supplémentaires stockent le résultat de chaque alternative (expr1 ou expr2).
Par conséquent, l'indexation des items peut être décalée par rapport aux parenthèses.
C'est une astuce importante à connaître lorsqu'ont travaille avec des expressions régulières dans VBA Excel.
Car cela peut parfois conduire à des comportements inattendus, mais en comprenant comment VBA traite les alternatives dans les groupes de captures, Ont peut adapter les manipulations en conséquence.
 
Dernière édition:
Vote positif 0 Vote négatif
Phil69970

Phil69970

XLDnaute Barbatruc
Re

Le plus long est la recherche de la ligne à extraire il me semble

1693496916084.png


Car l'extraction en elle-même est quasi instantanée chez moi.
 
Vote positif 0 Vote négatif
RyuAutodidacte

RyuAutodidacte

XLDnaute Impliqué
Phil69970 à dit:
Dans le fichier fourni par Ivan il cherche juste à extraire les données qui correspondent à la valeur

Regarde la pièce jointe 1177625


Regarde la pièce jointe 1177626
Cliquez pour agrandir...
@Phil69970 Merci du rappel, tout est ok chez moi il me faut juste la prise en compte de la référence
Donc petite modif à faire sur mon code

@Phil69970 , @laurent950
D'ailleurs pensez vous que cette référence peut être unique ?

@ivan27 Qu'en est il ?
Edit : Quel serait le nombre de lignes Max pour le tableau structuré dans la feuilles BD ?
 
Dernière édition:
Vote positif 0 Vote négatif
laurent950

laurent950

XLDnaute Barbatruc
Phil69970 à dit:
Le plus long est la recherche de la ligne à extraire il me semble
Cliquez pour agrandir...
@phi69970 en un seul passage avec l'objet collection (Compatible avec mac) on y consigne toutes les références et on y accèdes avec la clef (110142)
RyuAutodidacte à dit:
@Phil69970 , @laurent950
D'ailleurs pensez vous que cette référence peut être unique ?
Cliquez pour agrandir...
Idem Les doublons se traite avec l'Object collection c'est aussi ultra rapide a identifié les doublons
 
Vote positif 0 Vote négatif
Phil69970

Phil69970

XLDnaute Barbatruc
RyuAutodidacte à dit:
D'ailleurs pensez vous que cette référence peut être unique ?
Cliquez pour agrandir...

il semblerait qu'elle soit unique mais Ivan pourrait/devrait nous le dire.
ivan27 à dit:
En production la feuille BD compte environ 3000 lignes et le traitement prend environ 4 secondes. J
Cliquez pour agrandir...

Sur 3000 lignes dans la feuille BD et en allant chercher la dernière ligne (pas de chance !!!) de la colonne D
==> la macro met 0.07 seconde sur mon micro

1693518849620.png

1693518896590.png


Et 0.06 seconde si c'est la 1ere ligne de la colonne D

1693519137005.png

1693519215843.png


Cela me semble largement acceptable...... ;)
 
Vote positif 0 Vote négatif
RyuAutodidacte

RyuAutodidacte

XLDnaute Impliqué
laurent950 à dit:
@phi69970 en un seul passage avec l'objet collection (Compatible avec mac) on y consigne toutes les références et on y accèdes avec la clef (110142)

Idem Les doublons se traite avec l'Object collection c'est aussi ultra rapide a identifié les doublons
Cliquez pour agrandir...
Je suis un adepte de la collection déjà :D

@Phil69970 tout à fait d'accord, c'est du rapide et pour la recherche il y a aussi Application.Match
 
Vote positif 0 Vote négatif
RyuAutodidacte

RyuAutodidacte

XLDnaute Impliqué
laurent950 à dit:
Ce qui serait intéressant c'est de tester les diverses possibilités pour extraire les chaines de caractères
L'avantage de la Regex c'est que cela est plus simple une fois créer et a modifier pour en extraire les sous chaine directement. Avec 3000 lignes de textes cela peut être intéressant.


@RyuAutodidacte je vous ai noté l'astuce ci-dessous pour éviter les découpages et autres et tous faire avec la Regex avec les sous chaines entre parenthéses ( )
ici faut Lire cela
VB: 
((10)|(11)9) = ( 9) qui contient un Ou avec le séparateur |
= (( 10) | ( 11)9 ) encapsulé entre parenthése (  9) qui contient (10)|(11)
= ((20|0.98)) c'est comme cela qu'il faut lire
= le resultat sera celui obtenu dans l'encapsulation ( 9)
= Car ((Pas trouvé = "")|(Trouvé = 0.98)
= Alor Item 10 = "" mais l'item 11 = 0.98
et vis versa
= Car ((trouvé = 20)|(pas Trouvé = "")
= Alor Item 10 = 20 mais l'item 11 = ""
et donc le résultat se trouve a la racine de l'encapsulation est des deux soit
Item 9 = Le résultat obtenu (soit du 10 ou du 11)

Les sous chaines sont ranger comme cela :
VB: 
Pattern = "(GID\+\+)(\d{0,})(:)(\w{2})(\w+)(\+PAC\+)((\d?\d\.\d?\d)|(\d?\d)):((\d?\d\.\d?\d)|(\d?\d)):((\d?\d\.\d?\d)|(\d?\d))"
Pattern = "(0)(1)(2)(3)(4)(5)((7)|(8)6):((10)|(11)9):((13)|(14)12)"
Dans l'explorer VBE il faut ajouter 1 car l'Item commence a 1 voir ci-dessous
Pattern = "(1)(2)(3)(4)(5)(6)((8)|(9)7):((11)|(12)10):((14)|(15)13)"

Alors Pour exemple il est maintenant facile de retrouver la sous chaine : avec l'indice 9 soit Item 10 en lecture direct avec VBE
wsUM.Cells(wsUM.Cells(1048576, "L").End(xlUp).Row + 1, "L").Value = Match.SubMatches.Item(9)

Pour Conclure :
Lorsqu'une alternative (expr1 | expr2) est incluse dans un modèle de recherche régulière et qu'elle est encapsulée dans des parenthèses, elle génère des items supplémentaires dans les sous-chaines renvoyées par SubMatches.
Ces items supplémentaires stockent le résultat de chaque alternative (expr1 ou expr2).
Par conséquent, l'indexation des items peut être décalée par rapport aux parenthèses.
C'est une astuce importante à connaître lorsqu'ont travaille avec des expressions régulières dans VBA Excel.
Car cela peut parfois conduire à des comportements inattendus, mais en comprenant comment VBA traite les alternatives dans les groupes de captures, Ont peut adapter les manipulations en conséquence.
Cliquez pour agrandir...
Merci pour les explications, j'utilise pas souvent le regex mais j'en ai déjà utilisé

comme j'ai pas de PC alors qq capture de regex en ligne :

1693521211776.png

1693521227153.png

1693521243572.png
 
Vote positif 0 Vote négatif
RyuAutodidacte

RyuAutodidacte

XLDnaute Impliqué
@laurent950
oui dans le code d'origine on a ceci :
VB: 
wsUM.Cells(umRow, "H").Value = wsBD.Cells(i, "J").Value ' Colonne J

@ivan27 , @Phil69970 , @laurent950
Mon code rectifié qui prend en compte le N° de Bordereau (colonne J tjs inclus dans UM) :

Code à mettre en début de module :
VB: 
Option Explicit

Public Coll As Collection

La fonction de recherche :
Cette fonction permet de garder en mémoire tous les bordereaux existant
Donc quand on relance le code on fait juste appel au numéro de bordereau qui donne automatiquement la ligne correspondante de la variable tableau si le bordereau existe
VB: 
Function GetBordereau(Ref As String)
Dim VA, i As Long, L As String
    If Coll Is Nothing Then
        Set Coll = New Collection
        VA = ThisWorkbook.Sheets("BD").ListObjects(1).ListColumns(4).DataBodyRange.Value
        For i = 1 To UBound(VA)
            On Error Resume Next
            Coll.Add i, VA(i, 1)
            If Err Then
                Err.Clear:      L = Coll(VA(i, 1)) & "|":       Coll.Remove VA(i, 1):       Coll.Add L & i, VA(i, 1)
            End If
        Next
    End If
On Error Resume Next
    GetBordereau = Coll(CStr(Ref))
    If Err Then Err.Clear:      GetBordereau = Nothing
End Function
Dans le cas ou l'on supprime ou que l'on ajoute des bordereaux dans BD via un code il faut ajouter à ces codes au début:
Code: 
Set Coll = nothing

Le code (avec variables tableaux) :
VB: 
Sub GetGidPacTxT()
Dim UM As Worksheet, InitRowUM As Long, VA, L, x As Long, Txt$, y As Integer, Pos As Integer, PAC$, T!
Dim FindPAC As Integer, Deb As Integer, S, V, gidValue$, gidPart$, P, sumResult As Double

    SupprimerDonneesUM
 
    T = Timer
  
    VA = ThisWorkbook.Sheets("BD").ListObjects(1).DataBodyRange.Value
    Set UM = ThisWorkbook.Sheets("UM")
    InitRowUM = 10
 
    Application.ScreenUpdating = False

    L = GetBordereau(CStr(UM.Range("D3").Value)) 'Cherche les lignes correspondante au borderau
    If L <> "" Then
    L = Split(L, "|")
        For x = LBound(L) To UBound(L)
            Txt = VA(L(x), 2):        FindPAC = InStr(Txt, "+PAC+")

            If FindPAC = 0 Then
                ReDim V(1 To 1, 1 To 9)
                V(1, 1) = VA(L(x), 3):  V(1, 2) = VA(L(x), 1):  V(1, 3) = VA(L(x), 5):  V(1, 4) = VA(L(x), 6):  V(1, 5) = VA(L(x), 7)
                V(1, 6) = VA(L(x), 8): V(1, 7) = VA(L(x), 9): V(1, 8) = VA(L(x), 10): V(1, 9) = VA(L(x), 11)
                UM.Cells(InitRowUM, 1).Resize(UBound(V), UBound(V, 2)).Value = V
                InitRowUM = InitRowUM + 1
            Else
                Deb = InStrRev(Txt, "GID++", FindPAC)
                S = Mid(Txt, Deb):      S = Split(S, "GID++")
                ReDim V(1 To UBound(S), 1 To 15)
                For y = 1 To UBound(S)
                    Pos = InStr(S(y), ":"):     gidValue = Mid(S(y), 1, Pos - 1):       gidPart = Mid(S(y), Pos + 1, 2)
                    Pos = InStr(S(y), "+PAC+") + 5:     PAC = Mid(S(y), Pos):       P = Split(PAC, ":")

                    V(y, 1) = VA(L(x), 3):  V(y, 2) = VA(L(x), 1):  V(y, 3) = VA(L(x), 5):  V(y, 4) = VA(L(x), 6):  V(y, 5) = VA(L(x), 7)
                    V(y, 6) = VA(L(x), 8): V(y, 7) = VA(L(x), 9): V(y, 8) = VA(L(x), 10): V(y, 9) = VA(L(x), 11)

                    V(y, 11) = P(0): V(y, 12) = P(1): V(y, 13) = P(2): V(y, 14) = gidValue: V(y, 15) = gidPart
                    sumResult = sumResult + Evaluate(P(0) & " * " & P(1) & " * " & P(2) & " * " & gidValue)
                Next
                For y = 1 To UBound(S):      V(y, 10) = sumResult:      Next
                UM.Cells(InitRowUM, 1).Resize(UBound(V), UBound(V, 2)).Value = V
                InitRowUM = InitRowUM + UBound(V)
                sumResult = 0
            End If
        Next
    Else
        MsgBox "Borderau non trouvé"
    End If
 
    Application.ScreenUpdating = True

MsgBox "Processus: " & Format$(Timer - T, "0.0000s")
 
End Sub

Code existant pour la suppression des lignes :
VB: 
Sub SupprimerDonneesUM()
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets("UM")
 
    With ws
        .Rows("10:" & .Rows.Count).Delete
    End With
End Sub

Edit 1 et 2 : petite correction du nom de macro suppression et texte

Edit 3 : Légère modification de la function GetBordereau
VA = ThisWorkbook.Sheets("BD").ListObjects(1).DataBodyRange.Value
devient (et ce qui s'ensuit)
VA = ThisWorkbook.Sheets("BD").ListObjects(1).ListColumns(4).DataBodyRange.Value
 
Dernière édition:
Vote positif 0 Vote négatif

Discussions similaires

C
  • Résolu(e)
XL 2021 filtrer données puis envoi sur une autre feuille
Réponses
3
Affichages
485
sylvanu
sylvanu
O
  • Question
XL 2010 Besoin d'aide Excel pour Expert - récupérer données sur une autres feuille
Réponses
8
Affichages
412
AtTheOne
AtTheOne
hypo78
  • Question
XL 2016 Récupérer données sur plusieurs feuilles
2
Réponses
20
Affichages
1 K
hypo78
hypo78
S
  • Résolu(e)
XL 2016 copier des données d'une feuille à une autre selon critères et protection de la feuille 1
Réponses
6
Affichages
341
steph_29120
S
S
  • Résolu(e)
Microsoft 365 Récupérer la date dans un calendrier
Réponses
2
Affichages
341
sebastien176
S
R
  • Question
XL 2021 Récupérer des données dans plusieurs classeurs sans les ouvrir - Résolu
Réponses
10
Affichages
422
job75
job75
N
  • Question
Microsoft 365 afficher/masquer des lignes en fonction de la valeur d'une cellule qui aura été renseignée par une autre feuille (via un copier/collé automatique)
Réponses
5
Affichages
357
Nel'
N
C
  • Question
XL 2021 Cellules qui ne s'effacent pas sur formulaire et renvoi de valeurs du formulaire
Réponses
1
Affichages
317
gbinforme
G
cathodique
  • Résolu(e)
XL 2010 tableau de comptage sans doublon
2 3
Réponses
44
Affichages
1 K
cathodique
cathodique
M
  • Question
XL 2019 Transposer des données d'une feuille vers une autre sous forme de synthèse
Réponses
8
Affichages
185
mromain
mromain

Membres actuellement en ligne

9 membres et 127 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
314 720
Messages
2 112 189
Membres
111 457
dernier inscrit
anglade