Ceci est une page optimisée pour les mobiles. Cliquez sur ce texte pour afficher la vraie page.

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
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

laurent950

XLDnaute Barbatruc
Bonjour @ivan27 , @Phil69970 , @laurent950



Module Standard 1
Code: 
' 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

Code: 
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
 

Pièces jointes

  • Extraire chaine V2 (Regex Obtimisé).xlsm
    544.4 KB · Affichages: 3
Vote positif 0 Vote négatif

RyuAutodidacte

XLDnaute Impliqué
Bonjour,@ivan27,
Si vous pré-formatez manuellement vos colonnes (à ne faire qu'une fois) qui sont dans ce code :
VB: 
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" :
VB: 
' … … …
' … … …
' … … …
        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
 
Dernière édition:
Vote positif 0 Vote négatif
I

ivan27

XLDnaute Occasionnel
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
 

Pièces jointes

  • test1.xlsm
    46.7 KB · Affichages: 7
Vote positif 0 Vote négatif

RyuAutodidacte

XLDnaute Impliqué
Bonjour @ivan27 ,

Le numéro en colonne D n'est pas unique.
Cliquez pour agrandir...
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 :
VB: 
Option Explicit

Public Coll As Collection

La function :
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, 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 :
VB: 
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 :
VB: 
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
 
Vote positif 0 Vote négatif

RyuAutodidacte

XLDnaute Impliqué
ivan27 à dit:
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
Cliquez pour agrandir...
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):
VB: 
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"
 
Dernière édition:
Vote positif 0 Vote négatif
I

ivan27

XLDnaute Occasionnel
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
 
Vote positif 0 Vote négatif
Identifiez-vous ou inscrivez-vous pour participer.

Discussions similaires

C
  • Résolu(e)
XL 2021 filtrer données puis envoi sur une autre feuille
Réponses
3
Affichages
494
sylvanu
O
  • Question
XL 2010 Besoin d'aide Excel pour Expert - récupérer données sur une autres feuille
Réponses
8
Affichages
435
AtTheOne
  • Question
XL 2016 Récupérer données sur plusieurs feuilles
2
Réponses
20
Affichages
1 K
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
419
steph_29120
S
S
  • Résolu(e)
Microsoft 365 Récupérer la date dans un calendrier
Réponses
2
Affichages
364
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
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
  • Résolu(e)
XL 2010 tableau de comptage sans doublon
2 3
Réponses
44
Affichages
2 K
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
Menu
Connexion
S'inscrire
Les cookies sont requis pour utiliser ce site. Vous devez les accepter pour continuer à utiliser le site. En savoir plus…