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é
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 Barbatruc
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é
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é
@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
493
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
433
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
413
steph_29120
S
S
  • Résolu(e)
Microsoft 365 Récupérer la date dans un calendrier
Réponses
2
Affichages
362
sebastien176
S
R
  • Question
XL 2021 Récupérer des données dans plusieurs classeurs sans les ouvrir - Résolu
Réponses
10
Affichages
463
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
444
Nel'
N
C
  • Question
XL 2021 Cellules qui ne s'effacent pas sur formulaire et renvoi de valeurs du formulaire
Réponses
1
Affichages
345
gbinforme
G
cathodique
  • Résolu(e)
XL 2010 tableau de comptage sans doublon
2 3
Réponses
44
Affichages
2 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
261
mromain
mromain

Membres actuellement en ligne

19 membres et 124 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
315 083
Messages
2 116 041
Membres
112 641
dernier inscrit
chab77