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
I

ivan27

XLDnaute Occasionnel
Bonjour Phil69970, le forum
Merci beaucoup pour cette proposition.
Les valeurs récupérées sont correctes. Pourrais-tu apporter une petite modification STP pour que ton code fonctionne également lorsque la valeur à récupérer avant le signe ':' est supérieure à 9 ?

Exemple :
30:KGGID++23:EPDIM+PAC+0.8:0.8:0.92:LMPCI+20M
ou
30:KGGID++234:EPDIM+PAC+0.8:0.8:0.92:LMPCI+20M

Merci d'avance.
Ivan
 
Vote positif 0 Vote négatif
Phil69970

Phil69970

XLDnaute Barbatruc
Bonjour @ivan27 et @laurent950

@ivan27
ivan27 à dit:
Pourrais-tu apporter une petite modification STP pour que ton code fonctionne également lorsque la valeur à récupérer avant le signe ':' est supérieure à 9 ?
Cliquez pour agrandir...

Je te propose la version 2
Edit Fichier modifié pour déclaration d'une variable Public

* A noter : Pour mes essais j'ai modifié la cellule
Sheets("BD").Range("B2")
Cliquez pour agrandir...

Pour avoir ceci :

1693349121589.png
 

Pièces jointes

  • Extraire chaine V2.xlsm
    36.9 KB · Affichages: 9
Dernière édition:
Vote positif 0 Vote négatif
RyuAutodidacte

RyuAutodidacte

XLDnaute Impliqué
Supporter XLD
Bonjour à tous,

une autre approche (voir module 2)
ll n y a que la partie remplissage de UM mais pas la suite via les autres sub :
VB: 
Sub GetGidPacTxT()
Dim BD As Worksheet, UM As Worksheet, InitRowUM As Long, LRowBD As Long, x As Long, y As Integer
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

    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
            Next
            UM.Cells(InitRowUM, 1).Resize(UBound(V), UBound(V, 2)).Value = V
            InitRowUM = InitRowUM + UBound(V)
        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
 

Pièces jointes

  • Extraire chaine V1 (1).xlsm
    45.1 KB · Affichages: 8
Vote positif 0 Vote négatif
laurent950

laurent950

XLDnaute Accro
Bonsoir,

J'ai conçu le motif Regex. Il s'agit d'une expression régulière à localiser dans la zone de texte. Le motif est le suivant :
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))"

VB: 
' RECUPERATION DES DONNEES FEUILLE BD vers UM
Sub ExtractDataAAA()
    Dim wsBD As Worksheet, wsUM As Worksheet
    Dim reference As String, lastRowBD As Long, umRow As Long
    Dim i As Long
    Dim Matches As Object, Match As Object, Pattern As String
    Dim MatchKLM As Object ' Colonne K/L/M
    Dim text As String
    Dim rg As Range
   
    SupprimerDonneesUM
    Set wsBD = ThisWorkbook.Sheets("BD")
    Set wsUM = ThisWorkbook.Sheets("UM")

' Obtenir la référence saisie en D3 de la feuille UM
    reference = wsUM.Range("D3").Value
    lastRowBD = wsBD.Cells(wsBD.Rows.Count, "A").End(xlUp).Row

    For i = 2 To lastRowBD
        If wsBD.Cells(i, "D").Value = reference Then
            text = wsBD.Cells(i, "B").Value
            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))"
            Set Matches = GetMatches(text, Pattern)
 
                wsUM.Cells(wsUM.Cells(1048576, "B").End(xlUp).Row + 1, "B").Value = wsBD.Cells(i, "A").Value ' Colonne A
                wsUM.Cells(wsUM.Cells(1048576, "A").End(xlUp).Row + 1, "A").Value = wsBD.Cells(i, "C").Value ' Colonne C
                wsUM.Cells(wsUM.Cells(1048576, "C").End(xlUp).Row + 1, "C").Value = wsBD.Cells(i, "E").Value ' Colonne E
                wsUM.Cells(wsUM.Cells(1048576, "D").End(xlUp).Row + 1, "D").Value = wsBD.Cells(i, "F").Value ' Colonne F
                wsUM.Cells(wsUM.Cells(1048576, "E").End(xlUp).Row + 1, "E").Value = wsBD.Cells(i, "G").Value ' Colonne G
                wsUM.Cells(wsUM.Cells(1048576, "F").End(xlUp).Row + 1, "F").Value = wsBD.Cells(i, "H").Value ' Colonne H
                wsUM.Cells(wsUM.Cells(1048576, "G").End(xlUp).Row + 1, "G").Value = wsBD.Cells(i, "I").Value ' Colonne I
                wsUM.Cells(wsUM.Cells(1048576, "H").End(xlUp).Row + 1, "H").Value = wsBD.Cells(i, "J").Value ' Colonne J
                wsUM.Cells(wsUM.Cells(1048576, "I").End(xlUp).Row + 1, "I").Value = wsBD.Cells(i, "K").Value ' Colonne K
 
' Copier les valeurs des segments PAC et GID
            If Not Matches Is Nothing Then
                For Each Match In Matches
                    wsUM.Cells(wsUM.Cells(1048576, "K").End(xlUp).Row + 1, "K").Value = Match.SubMatches.Item(6)
                    wsUM.Cells(wsUM.Cells(1048576, "L").End(xlUp).Row + 1, "L").Value = Match.SubMatches.Item(9)
                    wsUM.Cells(wsUM.Cells(1048576, "M").End(xlUp).Row + 1, "M").Value = Match.SubMatches.Item(12)
                    wsUM.Cells(wsUM.Cells(1048576, 14).End(xlUp).Row + 1, "N").Value = Match.SubMatches.Item(1)
                    wsUM.Cells(wsUM.Cells(1048576, 15).End(xlUp).Row + 1, "O").Value = Match.SubMatches.Item(3)
                Next Match
                    Set rg = wsUM.Range(wsUM.Cells(wsUM.Cells(1048576, "A").End(xlUp).Row, 1), wsUM.Cells(wsUM.Cells(1048576, "A").End(xlUp).Row, 9))
                    If Matches.Count > 1 Then
                        rg.Copy Destination:=rg.Offset(1, 0).Resize(Matches.Count - 1, 9)
                    Else
                        rg.Copy rg
                    End If
            End If
    End If
Next i
Call CalculateColumnJ
Application.ScreenUpdating = True
End Sub
 
Dernière édition:
Vote positif 0 Vote négatif
I

ivan27

XLDnaute Occasionnel
Bonsoir à tous,

Désolé pour ma réponse tardive mais je suis en congés et parfois loin de mon ordinateur...

@Phil69970 : La prise en compte de tous les nombre est bien corrigée mais je viens de m'apercevoir d'un autre problème. Lorsqu'il y a un entier dans les dimensions, la ligne n'est pas récupérée. Exemples : 30:KGGID++1:EPDIM+PAC+1:0.8:0.92:LMPCI+20M ou 30:KGGID++1:EPDIM+PAC+0.5:0.8:3:LMPCI+20M

@laurent950 : J'ai bien conscience que mon code d'origine n'est pas du tout optimisé. En production la feuille BD compte environ 3000 lignes et le traitement prend environ 4 secondes. Je n'arrive pas à utiliser ton code, j'ai une erreur "Variable objet ou variable de bloc With non définie sur cette ligne :
VB: 
If gidMatches.Count > pacMatches.Count Then

@RyuAutodidacte : Test en cours.

Merci à tous

Ivan
 
Vote positif 0 Vote négatif
RyuAutodidacte

RyuAutodidacte

XLDnaute Impliqué
Supporter XLD
laurent950 à dit:
@RyuAutodidacte vous pouvez noter le texte pour rechercher les pattern qui vous manque ?
Cliquez pour agrandir...
Hello @laurent950
dsl je n'ai pas compris cette question. mais si il s'agit ce qui concerne les 2 dernières lignes de ma capture, c'est du texte tronqué de la cellule B2 de BD ou j'ai ajouté ce qui est ci-dessous
ivan27 à dit:
30:KGGID++1:EPDIM+PAC+1:0.8:0.92:LMPCI+20M ou 30:KGGID++1:EPDIM+PAC+0.5:0.8:3:LMPCI+20M
Cliquez pour agrandir...

concernant le fichier c'est le même qui est partagé sur mon post plus haut

Edit : je suis sur Mac et je n'ai pas accès à Set regex = CreateObject("VBScript.RegExp") qui est propre au PC, DU coup je m'arrange à faire mes codes de façon à ce qu'il soit multi plateforme PC/MAC
 
Dernière édition:
Vote positif 0 Vote négatif
RyuAutodidacte

RyuAutodidacte

XLDnaute Impliqué
Supporter XLD
@laurent950 , @ivan27
je remets mon fichier avec les déclarations de variables manquantes (2-3)
et les données que j'ai utilisé

Edit : le code pour ce qui ne veulent pas télécharger le fichier :
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

    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
            Next
            UM.Cells(InitRowUM, 1).Resize(UBound(V), UBound(V, 2)).Value = V
            InitRowUM = InitRowUM + UBound(V)
        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
 

Pièces jointes

  • Extraire chaine V1 (1).xlsm
    44.9 KB · Affichages: 4
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
214
sylvanu
sylvanu
hypo78
  • Question
XL 2016 Récupérer données sur plusieurs feuilles
2
Réponses
18
Affichages
564
Lolote83
L
S
  • Résolu(e)
Microsoft 365 Récupérer la date dans un calendrier
Réponses
2
Affichages
110
sebastien176
S
Y
  • Question
Microsoft 365 récupérer données de tableau structuré sur une plage
Réponses
2
Affichages
249
jpb388
jpb388
P
  • Question
XL 2019 Copier des cellules d'une feuille sur une autre
Réponses
2
Affichages
228
phoceenjo
P
H
  • Question
Power Query Récupérer une donnée dans des classeurs pour afficher le résultat dans un autre classeur
Réponses
5
Affichages
219
hijackfr
H
Darkopsix
  • Résolu(e)
XL 2021 Récupérer des données de fichiers dons les noms sont renseignés dans des cellules
Réponses
2
Affichages
420
Darkopsix
Darkopsix
R
  • Résolu(e)
XL 2021 Transformer des données
Réponses
4
Affichages
184
Richard30
R
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
251
ChTi160
ChTi160
G
  • Question
Microsoft 365 Choix et export de données (Résolu)
Réponses
4
Affichages
314
GClaire
G

Membres actuellement en ligne

6 membres et 79 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 220
Membres
103 158
dernier inscrit
laufin