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é
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é
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é
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é
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
486
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
413
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
342
steph_29120
S
S
  • Résolu(e)
Microsoft 365 Récupérer la date dans un calendrier
Réponses
2
Affichages
342
sebastien176
S
R
  • Question
XL 2021 Récupérer des données dans plusieurs classeurs sans les ouvrir - Résolu
Réponses
10
Affichages
423
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
358
Nel'
N
C
  • Question
XL 2021 Cellules qui ne s'effacent pas sur formulaire et renvoi de valeurs du formulaire
Réponses
1
Affichages
318
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
186
mromain
mromain

Membres actuellement en ligne

15 membres et 110 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 722
Messages
2 112 194
Membres
111 462
dernier inscrit
ymd76