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

[ivan27]

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.

 

[RyuAutodidacte]

Avec mon code
Test sur 10 000 lignes, je remet Coll à Nothing

Je fais une 2è recherche avec 3 ref. identique en début et en fin des 10000 lignes :

 

[RyuAutodidacte]

Bonjour @ivan27 , @Phil69970 , @laurent950

Le fichier, dernier code dans le module 3

 

[laurent950]

Bonjour @ivan27 , @Phil69970 , @laurent950

Module Standard 1

' RECUPERATION DES DONNEES FEUILLE BD vers UM
Sub ExtractDataFinal()
'
    T = Timer
'
    Dim wsBD As Worksheet
    Dim wsUM As Worksheet
        Set wsBD = ThisWorkbook.Worksheets("BD")
        Set wsUM = ThisWorkbook.Worksheets("UM")
'
    Dim Matches As Object, Match As Object, Pattern As String
    Dim MatchKLM As Object ' Colonne K/L/M
    Dim text As String

    Dim col As Collection
        Set col = New Collection
    Dim rowIndex As Long
'
    SupprimerDonneesUM
'
    On Error Resume Next
    For rowIndex = 1 To wsBD.ListObjects(1).ListRows.Count
        If Exists(col, CStr(wsBD.ListObjects(1).ListColumns(1).DataBodyRange.Cells(rowIndex, 4).Value)) = True Then
            Debug.Print "La clé existe déjà dans la collection: " & CStr(wsBD.ListObjects(1).ListColumns(1).DataBodyRange.Cells(rowIndex, 4).Value)
        Else
            col.Add wsBD.ListObjects(1).ListRows(rowIndex).Range.Resize(, wsBD.ListObjects(1).ListColumns.Count - 2).Value, key:=CStr(wsBD.ListObjects(1).ListColumns(1).DataBodyRange.Cells(rowIndex, 4).Value)
        End If
    Next rowIndex
    On Error GoTo 0

'   N° Bordereau
    Dim testValue As Variant
    Dim Temp, Borderau() As Variant
    On Error Resume Next
        Temp = col.Item(CStr(wsUM.Cells(3, 4).Value))
        testValue = CStr(Temp(1, 4))
    On Error GoTo 0 ' Rétablir la gestion normale des erreurs
'
    If IsEmpty(testValue) Then
        ' La clé n'existe pas dans la collection
        Dim testKey As String
            testKey = CStr(wsUM.Cells(3, 4).Value)
            Debug.Print "La clé n'existe pas dans la collection: " & testKey
            wsUM.Cells(wsUM.Cells(1048576, "B").End(xlUp).Row + 1, "B").Value = "N° Bordereau Inconnu" ' Colonne A
            wsUM.Cells(wsUM.Cells(1048576, "A").End(xlUp).Row + 1, "A").Value = "N° Bordereau Inconnu" ' Colonne C
            wsUM.Cells(wsUM.Cells(1048576, "C").End(xlUp).Row + 1, "C").Value = "N° Bordereau Inconnu" ' Colonne E
            wsUM.Cells(wsUM.Cells(1048576, "D").End(xlUp).Row + 1, "D").Value = "N° Bordereau Inconnu" ' Colonne F
            wsUM.Cells(wsUM.Cells(1048576, "E").End(xlUp).Row + 1, "E").Value = "N° Bordereau Inconnu" ' Colonne G
            wsUM.Cells(wsUM.Cells(1048576, "F").End(xlUp).Row + 1, "F").Value = "N° Bordereau Inconnu" ' Colonne H
            wsUM.Cells(wsUM.Cells(1048576, "G").End(xlUp).Row + 1, "G").Value = "N° Bordereau Inconnu" ' Colonne I
            wsUM.Cells(wsUM.Cells(1048576, "H").End(xlUp).Row + 1, "H").Value = "N° Bordereau Inconnu" ' Colonne J
            wsUM.Cells(wsUM.Cells(1048576, "I").End(xlUp).Row + 1, "I").Value = "N° Bordereau Inconnu" ' Colonne K
        Exit Sub
    End If
'
            text = CStr(Temp(1, 2))
            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)
'
        If Matches Is Nothing Then
            ' L'objet est à Nothing
            Debug.Print "L'objet est à Nothing"
            MsgBox "Il n'y a aucune Pattern dans cette Chaine de carractéres !"
        Exit Sub
    End If
'
    For Each Match In Matches
'       Copier les valeurs des segments PAC et GID
        ReDim Borderau(1 To 1, 1 To 15)
        Borderau(1, 2) = Temp(1, 1)                  ' Colonne A
        Borderau(1, 1) = Temp(1, 2)                  ' Colonne C
        Borderau(1, 3) = Temp(1, 3)                  ' Colonne E
        Borderau(1, 4) = Temp(1, 4)                  ' Colonne F
        Borderau(1, 5) = Temp(1, 5)                  ' Colonne G
        Borderau(1, 6) = Temp(1, 6)                  ' Colonne H
        Borderau(1, 7) = Temp(1, 7)                  ' Colonne I
        Borderau(1, 8) = Temp(1, 8)                 ' Colonne J
        Borderau(1, 9) = Temp(1, 9)                 ' Colonne K
        Borderau(1, 11) = Match.SubMatches.Item(6)   ' Regex
        Borderau(1, 12) = Match.SubMatches.Item(9)   ' Regex
        Borderau(1, 13) = Match.SubMatches.Item(12)  ' Regex
        Borderau(1, 14) = Match.SubMatches.Item(1)   ' Regex
        Borderau(1, 15) = Match.SubMatches.Item(3)   ' Regex
        wsUM.Cells(wsUM.Cells(1048576, "A").End(xlUp).Row + 1, "A").Resize(LBound(Borderau, 1), UBound(Borderau, 2)) = Borderau
    Next Match
'
    Call CalculateColumnJ
    Application.ScreenUpdating = True
'
    MsgBox "Processus: " & Format$(Timer - T, "0.0000s")
'
End Sub

Function Exists(ByRef col As Collection, ByVal key As String) As Boolean
' Le code suivant vérifie si une clé existe
    On Error GoTo EH
    IsObject (col.Item(key))
    Exists = True
EH:
End Function

Module Standard 2 (Non Obptimisé celui du Poste 1) les fonctions

Sub Remplir_P_Q()
maChaine = Sheets("BD").Range("B2")
positions = ""
separateur = ""
dernierePos = 1
Lig = 10
Do
    Pos = InStr(dernierePos, maChaine, "+PAC+")
    
    If Pos Then
        x = Mid(maChaine, Pos - 5, 2)
        y = Mid(maChaine, Pos - 7, 1)
        positions = positions & separateur & Pos
        separateur = "-"
        dernierePos = Pos + 1
    End If
    If Sheets("UM").Range("A" & Lig) <> "" Then
        Sheets("UM").Range("P" & Lig) = y
        Sheets("UM").Range("Q" & Lig) = x
    End If
    Lig = Lig + 1
Loop While Pos > 0

End Sub


Function GetMatches(text As String, Pattern As String) As Object
    Dim regex As Object
    Dim Matches As Object
    Dim Match As Object
    
    Set regex = CreateObject("VBScript.RegExp")
    regex.Global = True
    regex.MultiLine = True
    regex.IgnoreCase = True
    regex.Pattern = Pattern
    
    If regex.test(text) Then
        Set Matches = regex.Execute(text)
        Set GetMatches = Matches
    Else
        Set GetMatches = Nothing
    End If
End Function

' CALCUL DU VOLUME EDI
Sub CalculateColumnJ()
    Dim wsUM As Worksheet
    Dim lastRowUM As Long
    Dim i As Long
    
    ' RŽfŽrence de la feuille UM
    Set wsUM = ThisWorkbook.Sheets("UM")
    
    ' Trouver la dernire ligne utilisŽe dans la feuille UM
    lastRowUM = wsUM.Cells(wsUM.Rows.Count, "A").End(xlUp).Row
    
    ' Parcourir les lignes de la feuille UM pour effectuer les calculs en colonne J
    For i = 10 To lastRowUM
        Dim numRec As String
        numRec = wsUM.Cells(i, "B").Value
        Dim sumResult As Double
        sumResult = 0
        
        ' VŽrifier si des donnŽes existent en colonnes KLMN
        If wsUM.Cells(i, "K").Value <> "" And wsUM.Cells(i, "L").Value <> "" And wsUM.Cells(i, "M").Value <> "" And wsUM.Cells(i, "N").Value <> "" Then
            Dim kValue As Double
            Dim lValue As Double
            Dim mValue As Double
            Dim nValue As Double
            
            kValue = CDbl(wsUM.Cells(i, "K").Value)
            lValue = CDbl(wsUM.Cells(i, "L").Value)
            mValue = CDbl(wsUM.Cells(i, "M").Value)
            nValue = CDbl(wsUM.Cells(i, "N").Value)
            
            ' Effectuer le calcul K * L * M * N
            sumResult = kValue * lValue * mValue * nValue
        End If
        
        ' Rechercher d'autres lignes avec le mme numŽro de rŽcŽpissŽ
        Dim j As Long
        For j = i + 1 To lastRowUM
            If wsUM.Cells(j, "B").Value = numRec And wsUM.Cells(j, "K").Value <> "" And wsUM.Cells(j, "L").Value <> "" And wsUM.Cells(j, "M").Value <> "" And wsUM.Cells(j, "N").Value <> "" Then
                Dim kValue2 As Double
                Dim lValue2 As Double
                Dim mValue2 As Double
                Dim nValue2 As Double
                
                kValue2 = CDbl(wsUM.Cells(j, "K").Value)
                lValue2 = CDbl(wsUM.Cells(j, "L").Value)
                mValue2 = CDbl(wsUM.Cells(j, "M").Value)
                nValue2 = CDbl(wsUM.Cells(j, "N").Value)
                
                ' Ajouter au rŽsultat la multiplication K * L * M * N de la ligne suivante
                sumResult = sumResult + kValue2 * lValue2 * mValue2 * nValue2
            Else
                Exit For ' Sortir de la boucle ds que le numŽro de rŽcŽpissŽ change
            End If
        Next j
        
        ' Mettre le rŽsultat dans la colonne J pour chaque ligne correspondante
        For j = i To j - 1
            wsUM.Cells(j, "J").Value = sumResult
        Next j
        
        ' Aller ˆ la dernire ligne traitŽe
        i = j - 1
    Next i
Call FormaterColonnes
Call Bordures
End Sub

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

Sub FormaterColonnes()
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets("UM")
    
    With ws
        ' Point 2 - Format numŽrique entier pour colonne E
        .Range("E10:E" & .Cells(.Rows.Count, "E").End(xlUp).Row).NumberFormat = "0"
        
        ' Point 3 - Format numŽrique 2 dŽcimales pour colonnes F et G
        .Range("F10:G" & .Cells(.Rows.Count, "F").End(xlUp).Row).NumberFormat = "0.00"
        
        ' Point 4 - Format numŽrique 3 dŽcimales pour colonnes H, I et J
        .Range("H10:J" & .Cells(.Rows.Count, "H").End(xlUp).Row).NumberFormat = "0.000"
        
        ' Point 5 - Format numŽrique 2 dŽcimales pour colonnes K, L et M
        .Range("K10:M" & .Cells(.Rows.Count, "K").End(xlUp).Row).NumberFormat = "0.00"
        
        ' Point 6 - Format numŽrique entier pour colonne N
        .Range("N10:N" & .Cells(.Rows.Count, "N").End(xlUp).Row).NumberFormat = "0"
    End With
End Sub

Sub Bordures()
Range("A10", "O" & Range("A65000").End(xlUp).Row).Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlThin
    End With
    Selection.Borders(xlEdgeTop).LineStyle = xlNone
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlHairline
    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)
    
    Range("A9").Select
    
End Sub

 

[laurent950]

Re.
Avec le Test sur 10 000 lignes, je remet Coll à Nothing vous faite comment ?

 

[RyuAutodidacte]

Sur 1 005 769 Lignes !
Test sur 10 000 lignes, je remet Coll à Nothing vous faite comment ?

Regarde la pièce jointe 1177696
Regarde la pièce jointe 1177697

je le fait là (ou on peut le mettre dans une sub) :

vous avez une erreur de mémoire on dirait ? dans quelles conditions c'est apparu ?

 

[RyuAutodidacte]

C'est pour que la function relist de nouveau toutes les réfs

 

[RyuAutodidacte]

Bonjour,@ivan27,
Si vous pré-formatez manuellement vos colonnes (à ne faire qu'une fois) qui sont dans ce code :

Sub FormaterColonnes()
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets("UM")
 
    With ws
        ' Point 2 - Format numérique entier pour colonne E
        .Range("E10:E" & .Cells(.Rows.Count, "E").End(xlUp).Row).NumberFormat = "0"
    
        ' Point 3 - Format numérique 2 décimales pour colonnes F et G
        .Range("F10:G" & .Cells(.Rows.Count, "F").End(xlUp).Row).NumberFormat = "0.00"
    
        ' Point 4 - Format numérique 3 décimales pour colonnes H, I et J
        .Range("H10:J" & .Cells(.Rows.Count, "H").End(xlUp).Row).NumberFormat = "0.000"
    
        ' Point 5 - Format numérique 2 décimales pour colonnes K, L et M
        .Range("K10:M" & .Cells(.Rows.Count, "K").End(xlUp).Row).NumberFormat = "0.00"
    
        ' Point 6 - Format numérique entier pour colonne N
        .Range("N10:N" & .Cells(.Rows.Count, "N").End(xlUp).Row).NumberFormat = "0"
    End With
End Sub

Ce code devient alors inutile
Résultat en ayant rajouté le pré-formatage des nombres sur les colonnes concernée à partir de la ligne 10 :

PS : Pour la macro "Bordures" la rajouter avant dans mon code avant : "Else" :

' … … …
' … … …
' … … …
        Next
        Bordures
    Else
        MsgBox "Borderau non trouvé"
    End If

    Application.ScreenUpdating = True

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

Edit : modif sur l'emplacement de Bordure

 

[ivan27]

Bonjour le forum, Phil69570, laurent950, RyuAutodidacte

Je reviens de vacances et je constate que vous n'avez pas chômé. Je constate également que le fichier que j'ai communiqué initialement n'était pas suffisamment précis et je m'en excuse.
Le numéro en colonne D n'est pas unique. Aussi, je vous prie de bien vouloir trouver ci-joint un autre fichier, comportant un plus grand nombre de lignes test avec le code d'origine dans lequel seul le pattern a été modifié pour prendre en compte les entiers.
Désolé pour ce contre-temps. Je vous réitère mes remerciements.
Bien cordialement et bonne journée
Ivan

 

[RyuAutodidacte]

Bonjour le forum, Phil69570, laurent950, RyuAutodidacte

Je reviens de vacances et je constate que vous n'avez pas chômé. Je constate également que le fichier que j'ai communiqué initialement n'était pas suffisamment précis et je m'en excuse.
Le numéro en colonne D n'est pas unique. Aussi, je vous prie de bien vouloir trouver ci-joint un autre fichier, comportant un plus grand nombre de lignes test avec le code d'origine dans lequel seul le pattern a été modifié pour prendre en compte les entiers.
Désolé pour ce contre-temps. Je vous réitère mes remerciements.
Bien cordialement et bonne journée
Ivan

Bonjour @ivan27 ,

Le numéro en colonne D n'est pas unique.

je pense pas que vous ayez testé mon code, car ma fonction (Function GetBordereau(Ref As String))
prend en compte, le fait qu'il peut y avoir plusieurs réf identiques.

PS : Pourquoi il y a 3 soulignements en rouge ? pour indiquer que c'est faux ?

N'hésitez pas si vous avez des questions

j'ai en résultat ceci :

je remets le code ici (il y a tout même la colonne J) :

En début de module :

Option Explicit

Public Coll As Collection

La function :

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

le code principal :

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
        Bordures
    Else
        MsgBox "Borderau non trouvé"
    End If
 
    Application.ScreenUpdating = True

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

Codes existant :

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

Sub Bordures()
Range("A10", "O" & Range("A65000").End(xlUp).Row).Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlThin
    End With
    Selection.Borders(xlEdgeTop).LineStyle = xlNone
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlHairline
    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)
   
    Range("A9").Select
   
End Sub

 

[RyuAutodidacte]

@ivan27
PS : Le format des colonnes je l'ai paramétré manuellement donc je n'ai plus besoin de cette macro, c'est automatique à l'insertion des données

 

[ivan27]

Re bonjour à tous,
@RyuAutodidacte : Le rouge c'était bien pour les erreurs.
A priori votre code fonctionne parfaitement.
Merci à vous.
Je fais des tests avec mon fichier de production et je reviens.
Ivan

 

[ivan27]

Bonjour à tous,
@RyuAutodidacte : Je vous confirme que tout fonctionne bien en production. J'aurais peut-être l'occasion d'ouvrir un autre ticket sur le même fichier pour l'améliorer... Encore merci.
Bien cordialement
Ivan

 

[RyuAutodidacte]

Bonjour à tous,
@RyuAutodidacte : Je vous confirme que tout fonctionne bien en production. J'aurais peut-être l'occasion d'ouvrir un autre ticket sur le même fichier pour l'améliorer... Encore merci.
Bien cordialement
Ivan

Bonjour @ivan27 ,

Super, bonne nouvelle.

Je ne connais pas toutes vos procédures : Ajout / Suppression / modification des Réfs lignes et/ou données dans BD
(codes supplémentaires dont on a pas la connaissance)

Donc important :
Bien mettre dans ces codes (en début):

Set Coll = nothing

Cela permet de re-lister l'ensemble des réfs correctement.

Pour explication :

• - A la 1ere Recherche, les réfs/lignes sont listées et sont enregistrées en mémoire, donc : …
  
  
• - A la 2ème recherche et +, comme les réfs sont en mémoire, la function ne boucle plus sur la réfs., on appelle directement la réf. recherchée (Coll(MaRef)) ce qui nous donne directement la ou les lignes correspondante à la réf voulue.
  Par conséquent si on a : Ajout / Suppression / modification il faut réinitialiser Coll avec le code ci-dessus dans les Sub concernant les Ajouts / Suppressions / modifications

Ces précisions sont importantes pour que le déroulements des recherches soient correct.
Bien sur on peut changer cela si besoin dans le cas ou vous voulez faire autrement, le changement est plus que minime …

- Sur ce post vous avez le temps sur 10 000 lignes (entre la 1ère et 2ème Recherche)

- De mémoire j'ai essayé à plus d'un million de lignes

en 1ère Recherche j'étais à environ + ou - 11,5 seconde​

en 2è Recherche et + j'étais à environ 1 seconde​

​

Edit : petite modif, ajout de 2 mots "dans BD"

 

[ivan27]

Merci pour cette explication,
J'ai ajouté la ligne au début de mon code d'actualisation des données.
Bien cordialement et bonne fin de journée

 

[ivan27]

Bonsoir à tous,

@RyuAutodidacte : Je me permets déjà de relancer cet échange car je viens de tomber sur une exception qui n'a pas été prise en compte.
30:KGGID++1:EPDIM+PAC+0.8:0.8:0.92:LMPCI+20M

Le code récupère les 2 caractères après les ":" (ci-dessus : EP) or, il arrive quelques fois qu'il faille récupérer 3 caractères et non 2.

Est-il possible de changer la règle d'identification pour récupérer les caractère situés entre ":" et "DIM"

Exemple : 30:KGGID++1:MTVDIM+PAC+0.8:0.8:0.92:LMPCI+20M

Dans l'exemple ci-dessus je dois récupérer "MTV"

Bien cordialement,

Ivan