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é
Supporter XLD
Re @ivan27 ,

j'ai une question importante :
qd ds le texte on trouve PAC il es associé avec les …GID++,
Mais on trouve aussi des GID++ sans PAC

De mon coté je teste si le PAC Existe dans le text et me rapporte à son GID++ (le 1er avant le 1er PAC),
afin de splitter sur le GID++ pour obtenir l'ensemble GID++/PAC.

La question :
Dans le cas ou l'on trouve un PAC dans le texte via le test Instr ,
se pourrait il que l'on trouve un ou plusieurs GID++ vers la fin du texte sans PAC ??

Sinon j'ai fait des modifs, mais je préfère attendre votre réponse à ce sujet afn de vous donner la meilleure option
 
Vote positif 0 Vote négatif
RyuAutodidacte

RyuAutodidacte

XLDnaute Impliqué
Supporter XLD
un aperçu de l'autre option qui se met en place facilement :
le principe : spliter sur les PAC et prendre un nb de caractères avant et après (PAC = Mid(Txt, L - 20, 35)) afin d'obtenir les valeurs voulues

VB: 
Sub TEST()
Dim Txt As String, S, Pos As Integer, gidValue, gidPart, i As Integer, Deb As Integer

'    Txt = "30:KGGID++1:MTVDIM+PAC+0.8:0.8:0.92:LMPCI+20M"
   
    Txt = "fichier :00033923_456723c6.scodate : 21/08/2023 - 17:20partenaire : testediUNH+S456723C6001+SCONTR:3:2:GT:GTF210BGM++1100080NAD+FW+PARTENAIRE:05++Nom Partenaire" & _
    "+DEP+230821NAD+DP+32823317600028:05++TRANSPORTEURTSR+++3CAG+P+VTDT++++3+::LTD215DOC+730+++ACG+1100080EQD+TIRSEL+6579603UNS+DRFF+CN+23000380387:7GID++2:23" & _
    "+1:99MSE+CGW+1136:KGNAD+CN+++DEST+ADRESSE DEST+VILLE DEST++67700+FRDTM+DLD+230824NAD+CO+00138495++CAG+P+V+DAP++++++++LTSR+CL +D+3TXT+" & _
    "DEL+LIVRAISON AU PLUS TARD LE24082023TXT+DEL+testTXT+DEL+PRIO CLIENTTXT+DEL+testGDS+G+ErsatzteilePCI+20MSE+CGW" & _
    "+660:KGGID++18:EPDIM+PAC+3:0.8:0.8:LMPCI+23MSE+CGW+476:KGGID++9:FPDIM+PAC+1.2:0.8:0.75:LMGIN+BN+00340358994015765836GIN+BN+00340358994015765843DOC+WBL+++ACG+23000380387DOC+AAO+++INF+748078"
   
    If InStr(Txt, "+PAC+") <> 0 Then
        S = Split(Txt, "+PAC+")
        For i = LBound(S) To UBound(S)
            L = L + 5 + Len(S(i))
            PAC = Mid(Txt, L - 20, 35)
            V = Split(Split(PAC, "GID++")(1), ":")
            gidValue = V(0):        Debug.Print "gidValue = " & gidValue
            gidPart = Mid(V(1), 1, InStr(V(1), "DIM") - 1):        Debug.Print "gidPart = " & gidPart
            P1 = Mid(V(1), InStrRev(V(1), "+") + 1):        Debug.Print "P1 = " & P1
            P2 = V(2):        Debug.Print "P2 = " & P2
            P3 = V(3):        Debug.Print "P3 = " & P3
            If UBound(S) = i + 1 Then Exit For
        Next
    End If
End Sub

Vous pouvez le tester sur un classeur vierge
 
Vote positif 0 Vote négatif
RyuAutodidacte

RyuAutodidacte

XLDnaute Impliqué
Supporter XLD
ivan27 à dit:
Je confirme @RyuAutodidacte DIM+PAC+ est un format normé.
Cliquez pour agrandir...
Du coup j'ai fait un nouvel Algo.
VB: 
Sub TEST()
Dim Txt As String, S, Pos As Integer, gidValue, gidPart, i As Integer, Deb As Integer

'    Txt = "30:KGGID++1:MTVDIM+PAC+0.8:0.8:0.92:LMPCI+20M"
  
    Txt = "fichier :00033923_456723c6.scodate : 21/08/2023 - 17:20partenaire : testediUNH+S456723C6001+SCONTR:3:2:GT:GTF210BGM++1100080NAD+FW+PARTENAIRE:05++Nom Partenaire" & _
    "+DEP+230821NAD+DP+32823317600028:05++TRANSPORTEURTSR+++3CAG+P+VTDT++++3+::LTD215DOC+730+++ACG+1100080EQD+TIRSEL+6579603UNS+DRFF+CN+23000380387:7GID++2:23" & _
    "+1:99MSE+CGW+1136:KGNAD+CN+++DEST+ADRESSE DEST+VILLE DEST++67700+FRDTM+DLD+230824NAD+CO+00138495++CAG+P+V+DAP++++++++LTSR+CL +D+3TXT+" & _
    "DEL+LIVRAISON AU PLUS TARD LE24082023TXT+DEL+testTXT+DEL+PRIO CLIENTTXT+DEL+testGDS+G+ErsatzteilePCI+20MSE+CGW" & _
    "+660:KGGID++18:EPDIM+PAC+3:0.8:0.8:LMPCI+23MSE+CGW+476:KGGID++9:FPDIM+PAC+1.2:0.8:0.75:LMGIN+BN+00340358994015765836GIN+BN+00340358994015765843DOC+WBL+++ACG+23000380387DOC+AAO+++INF+748078"
  
    If InStr(Txt, "DIM+PAC+") <> 0 Then
        S = Split(Txt, "DIM+PAC+")
        For i = LBound(S) To UBound(S)
            V = InStrRev(S(i), "GID++") + 5
            GID = Split(Mid(S(i), V, 10), ":"):     gidValue = GID(0):      gidPart = GID(1)
            Debug.Print "gidValue = " & gidValue:       Debug.Print "gidPart = " & gidPart
            
            PAC = Split(S(i + 1), ":"):         P1 = PAC(0):    P2 = PAC(1):     P3 = PAC(2)
            Debug.Print "P1 = " & P1:   Debug.Print "P2 = " & P2:       Debug.Print "P3 = " & P3
            If UBound(S) = i + 1 Then Exit For
        Next
    End If
End Sub

bien plus simple
Je ferai les modif ce soir

Bien a vous
 
Vote positif 0 Vote négatif
RyuAutodidacte

RyuAutodidacte

XLDnaute Impliqué
Supporter XLD
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 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, CStr(VA(i, 1))
            If Err Then
                Err.Clear:      L = Coll(CStr(VA(i, 1))) & "|":       Coll.Remove CStr(VA(i, 1)):       Coll.Add L & i, CStr(VA(i, 1))
            End If
        Next
    End If
On Error Resume Next
    GetBordereau = Coll(Ref)
    If Err Then Err.Clear:      GetBordereau = Nothing
End Function

Le code principal corrigé (prise en compte d'un nouveau détail + amélioration de algorithme):
VB: 
Sub GetGidPacTxT()
Dim UM As Worksheet, InitRowUM As Long, VA, L, x As Long, Txt$, y As Integer, i As Integer, T!
Dim FindPAC As Integer, S, V, Pos As Integer, PAC, GID, gidValue$, gidPart$, 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, "DIM+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
               S = Split(Txt, "DIM+PAC+")
                ReDim V(1 To UBound(S), 1 To 15)
                For y = LBound(S) To UBound(S)
                    i = y + 1:          Pos = InStrRev(S(y), "GID++") + 5
                    GID = Split(Mid(S(y), Pos, 10), ":"):     gidValue = GID(0):      gidPart = GID(1):     PAC = Split(S(i), ":")
                    
                    V(i, 1) = VA(L(x), 3):  V(i, 2) = VA(L(x), 1):  V(i, 3) = VA(L(x), 5):  V(i, 4) = VA(L(x), 6):  V(i, 5) = VA(L(x), 7)
                    V(i, 6) = VA(L(x), 8): V(i, 7) = VA(L(x), 9): V(i, 8) = VA(L(x), 10): V(i, 9) = VA(L(x), 11)

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

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

Codes Existant :
VB: 
Sub SupprimerDonneesUM()
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets("UM")
    With ws
        .Rows("10:" & .Rows.Count).Delete
    End With
    Set ws = Nothing
End Sub
Celui-ci je l'ai modifié en précisant la feuille (à voir si vous voulez le prendre ou garder l'ancien) :
Code: 
Sub Bordures()
    With Sheets("UM")
        Application.Goto .Range("A9")
        With .Range("A10", "O" & Range("A65000").End(xlUp).Row)
            .Borders(xlDiagonalDown).LineStyle = xlNone
            .Borders(xlDiagonalUp).LineStyle = xlNone
            With .Borders(xlEdgeLeft)
                .LineStyle = xlContinuous
                .ColorIndex = xlAutomatic
                .TintAndShade = 0
                .Weight = xlThin
            End With
            .Borders(xlEdgeTop).LineStyle = xlNone
            With .Borders(xlEdgeBottom)
                .LineStyle = xlContinuous
                .ColorIndex = xlAutomatic
                .TintAndShade = 0
                .Weight = xlThin
            End With
            With .Borders(xlEdgeRight)
                .LineStyle = xlContinuous
                .ColorIndex = xlAutomatic
                .TintAndShade = 0
                .Weight = xlThin
            End With
            With .Borders(xlInsideVertical)
                .LineStyle = xlContinuous
                .ColorIndex = xlAutomatic
                .TintAndShade = 0
                .Weight = xlThin
            End With
            With .Borders(xlInsideHorizontal)
                .LineStyle = xlContinuous
                .ColorIndex = xlAutomatic
                .TintAndShade = 0
                .Weight = xlHairline
            End With
        End With
        .Range("E10", "H" & Range("A65000").End(xlUp).Row).Interior.Color = RGB(230, 240, 255)
        .Range("J10", "O" & Range("A65000").End(xlUp).Row).Interior.Color = RGB(230, 240, 255)
    End With
End Sub
 
Vote positif 0 Vote négatif
Solution

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
565
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
251
jpb388
jpb388
P
  • Question
XL 2019 Copier des cellules d'une feuille sur une autre
Réponses
2
Affichages
230
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
222
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
422
Darkopsix
Darkopsix
R
  • Résolu(e)
XL 2021 Transformer des données
Réponses
4
Affichages
186
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
252
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

18 membres et 105 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 207
Messages
2 086 233
Membres
103 161
dernier inscrit
Rogombe bryan