Filtrage d'un immense fichier

siocnarf

XLDnaute Occasionnel
Bonjour,

J'ai un bon problème devant moi.

1. J'ai une liste de tous les exe d'un parc de 1400 postes ce qui donne environ 400 000 lignes. Le tableau contient le nom de l'ordinateur, l'identifiant de la personne, le système d'exploitation, le nom du fichier, son emplacement, sa version et sa description. (voir le fichier test.xlsx).
2. Je dois épurer cette liste au maximum pour ne garder que certains exe.

Ma solution:

J'ai créé un dictionnaire dans un autre classeur et je le charge comme array avec un vba. Puis pour chaque entrée dans le dictionnaire, je fais une recherche dans la colonne appropriée et supprime la ligne. Je refais la même recherche tant que le mot existe.

Une fois que le mot n'est plus là, je prend la seconde entrée dans le dictionnaire. Actuellement, le dictionnaire a environ 300 lignes mais un même mot du dictionnaire peut apparaitre 5000 fois dans le tableau.

Mon problème:
Si par exemple, je recherche le mot Prowin.exe, ce mot apparaît à différent endroits dans mon tableau mais toujours dans la même colonne. Or l'action de recherche et de suppression de la ligne unique prend du temps.

Serait-il possible de rechercher toutes les chaines contenant Prowin.exe dans une colonne et de simplement supprimer les lignes?

En pièce jointe, vous retrouverez un échantillon de mon fichier. Je n'y ai laissé que les Office.

Que devrais-je faire pour optimiser la suppression de mes lignes afin de ne conserver que les Outlook et les Wordview. Dans les faits mon dictionnaire a plus de mot. Parfois les mots à supprimer font parti de la chaine de caractère dans les descriptions.



Je remarque que suivant mon exécution, le traitement est lent et accélère puisqu'il y a de moins en moins de ligne. Mais cela demande tout de même du temps.

Voici un échantillon de mon code:

Code:
Sub Supprimevaleurs(S_StrNomduFichier, S_StrChiffrierdestination, S_tablodesretraits, S_VFeuilDataCol4, S_VFeuilDataCol6, S_VFeuilDataCol7)

Dim LDerniereLigne As Long
Dim LDerniereColonne As Long
Dim LPosition As Long
Dim Trouve As Range
Dim PlageDeRecherche As Range
Dim Valeur_Cherchee As String
Dim AdresseTrouvee As String
Dim L_ligne As Long


'http://www.commentcamarche.net/faq/36886-vba-recherche-de-donnees-la-methode-find

Workbooks(S_StrNomduFichier).Activate
Sheets(1).Select

'On détermine les dernières lignes et colonnes du tableau
LDerniereColonne = ActiveSheet.UsedRange.Columns.Count
LDerniereLigne = Sheets(1).Cells(Application.Rows.Count, 1).End(xlUp).Row
'LDerniereLigne = Columns(1).Find("*", , , , xlByColumns, xlPrevious).Row


For LPosition = LBound(S_tablodesretraits, 1) To UBound(S_tablodesretraits, 1) 'On va passer toutes les lignes du dictionnaire
    
     Select Case S_tablodesretraits(LPosition, 2) 
        Case S_VFeuilDataCol4(0) 'On fait une recherche avec le nom du fichier
        
                Valeur_Cherchee = S_tablodesretraits(LPosition, 1) 'Valeur recherchée
                Set PlageDeRecherche = ActiveSheet.Columns(4)
                
                Call Cherche(PlageDeRecherche, S_StrNomduFichier, Valeur_Cherchee)
             
        Case S_VFeuilDataCol6(0) 'On fait une recherche avec l'emplacement du fichier
        
               Valeur_Cherchee = S_tablodesretraits(LPosition, 1) 'Valeur recherchée
                Set PlageDeRecherche = ActiveSheet.Columns(6)
                
                Call Cherche(PlageDeRecherche, S_StrNomduFichier, Valeur_Cherchee)
            
        Case S_VFeuilDataCol7(0) ' On fait une recherche avec la description du fichier.
                         
                Valeur_Cherchee = S_tablodesretraits(LPosition, 1) 'Valeur recherchée
                Set PlageDeRecherche = ActiveSheet.Columns(7)
                
                Call Cherche(PlageDeRecherche, S_StrNomduFichier, Valeur_Cherchee)
            
    End Select
 
Next

End Sub
'============================================
'============================================
Sub Cherche(C_PlageDeRecherche, C_StrNomduFichier, C_Valeur_Cherchee)

Set Trouve = C_PlageDeRecherche.Cells.Find(What:=C_Valeur_Cherchee, LookAt:=xlPart)

  Do
            
     If Not Trouve Is Nothing Then
            
           Workbooks(C_StrNomduFichier).Activate
           Sheets(1).Select
                   
          'http://www.commentcamarche.net/faq/18696-vba-recherche-find-avec-retour-multiple
          'AdresseTrouvee = Trouve.Address
          'AdresseTrouvee = Trouve.Row
          L_ligne = Trouve.Row
          'Rows(L_ligne & ":" & L_ligne).Select
          'Range("A472526:H472526").Select
          'Workbooks(S_StrNomduFichier).Sheets(1).Range("A472526:H472526").Select
           Workbooks(C_StrNomduFichier).Sheets(1).Rows(L_ligne & ":" & L_ligne).Select
           'Rows("1:1").Select
          [B] Selection.Delete Shift:=xlUp[/B]
           Set Trouve = C_PlageDeRecherche.Cells.Find(What:=C_Valeur_Cherchee, LookAt:=xlPart)
                    
       End If
                
   Loop While Not Trouve Is Nothing 'Tant que l'on trouve des valeurs on fait la recherche
           

End Sub

SVP, soyez indulgent pour mon code :) Mais je suis évidemment ouvert aux propositions.
 

Pièces jointes

  • test.xlsx
    559 KB · Affichages: 60
  • Épuration des exe.xls
    103 KB · Affichages: 66
  • test.xlsx
    559 KB · Affichages: 65
  • test.xlsx
    559 KB · Affichages: 62
Dernière édition:

Xwprft

XLDnaute Junior
Re : Filtrage d'un immense fichier

Bonjour siocnarf,

Je crois que j'utiliserai les filtres.
L'avantage c'est de chercher en une seule fois l'occurrence d'une chaine dans toute la colonne.
Il n'y a pas besoin de gérer le balayage de la 1ère à la dernière ligne.
Regarde le fichier joint.
Il y a un embryon de VBA.

Note : j'avoue n'avoir jamais travaillé avec des fichiers de 400 000 lignes ...
A+
 

Pièces jointes

  • filtrage-dun-immense-fichier-test.xlsm
    534 KB · Affichages: 39

job75

XLDnaute Barbatruc
Re : Filtrage d'un immense fichier

Bonjour siocnarf, Xwprft,

Voyez cette macro dans le fichier Épuration des exe :

Code:
Sub Epuration()
Dim t#, nomfich$, a1$, a2$, f$
t = Timer
nomfich = "test.xlsx" 'nom à adapter
On Error Resume Next
If IsError(Workbooks(nomfich)) Then MsgBox "Ouvrez " & nomfich: Exit Sub
On Error GoTo 0
'---adresses à adapter---
a1 = Feuil2.[A2:A290].Address(, , xlR1C1, True)
a2 = Feuil2.[B2:B290].Address(, , xlR1C1, True)
'---formule---
f = "=LN(SUMPRODUCT((RC1:RC7=" & a1 & ")*(R1C1:R1C7=" & a2 & ")))"
'---traitement du fichier---
Application.ScreenUpdating = False
With Workbooks(nomfich).Sheets(1).UsedRange
  .Columns(8).FormulaR1C1 = f 'en colonne H
  .Columns(8) = .Columns(8).Value 'ne garde que les valeurs
  'le tri place les nombres en bas du tableau (pour accélérer)
  .Resize(, 8).Sort .Columns(8), xlDescending, Header:=xlYes
  On Error Resume Next 's'il n'y a rien à supprimer
  .Columns(8).SpecialCells(xlCellTypeConstants, 1).EntireRow.Delete
  .Columns(8).Delete xlToLeft
  Application.Goto .Cells(1), True
End With
Application.ScreenUpdating = True
MsgBox "Durée " & Format(Timer - t, "0.0 \s") 'facultatif...
End Sub
Pour obtenir le filtrage, la macro entre en colonne H du fichier test.xlsx cette formule :

Code:
=LN(SOMMEPROD(($A1:$G1='[Épuration des exe.xls]DictionnaireMOTSASUPPRIMER'!$A$2:$A$290)*($A$1:$G$1='[Épuration des exe.xls]DictionnaireMOTSASUPPRIMER'!$B$2:$B$290)))
Sur Win 7 - Excel 2010 l'épuration du fichier de 30750 lignes prend 16,6 secondes.

Fichiers joints.

A+
 

Pièces jointes

  • test.xlsx
    578.9 KB · Affichages: 35
  • test.xlsx
    578.9 KB · Affichages: 50
  • test.xlsx
    578.9 KB · Affichages: 33
  • Épuration des exe(1).xls
    63 KB · Affichages: 42

job75

XLDnaute Barbatruc
Re : Filtrage d'un immense fichier

Re,

Si, comme sur l'exemple, les textes recherchés sont toujours en colonne D (4) ou G (7) :

Code:
Sub Epuration()
Dim t#, nomfich$, a1$, a2$, f$
t = Timer
nomfich = "test.xlsx" 'nom à adapter
On Error Resume Next
If IsError(Workbooks(nomfich)) Then MsgBox "Ouvrez " & nomfich: Exit Sub
On Error GoTo 0
'---adresses à adapter---
a1 = Feuil2.[A2:A290].Address(, , xlR1C1, True)
a2 = Feuil2.[B2:B290].Address(, , xlR1C1, True)
'---formule---
f = "=LN(SUMPRODUCT((RC4=" & a1 & ")*(R1C4=" & a2 & ")+(RC7=" & a1 & ")*(R1C7=" & a2 & ")))"
'---traitement du fichier---
Application.ScreenUpdating = False
With Workbooks(nomfich).Sheets(1).UsedRange
  .Columns(8).FormulaR1C1 = f 'en colonne H
  .Columns(8) = .Columns(8).Value 'ne garde que les valeurs
  'le tri place les nombres en bas du tableau (pour accélérer)
  .Resize(, 8).Sort .Columns(8), xlDescending, Header:=xlYes
  On Error Resume Next 's'il n'y a rien à supprimer
  .Columns(8).SpecialCells(xlCellTypeConstants, 1).EntireRow.Delete
  .Columns(8).Delete xlToLeft
  Application.Goto .Cells(1), True
End With
Application.ScreenUpdating = True
MsgBox "Durée " & Format(Timer - t, "0.0 \s") 'facultatif...
End Sub
Fichier (2), la durée d'exécution passe à 6,3 secondes.

A+
 

Pièces jointes

  • test.xlsx
    578.9 KB · Affichages: 37
  • test.xlsx
    578.9 KB · Affichages: 37
  • test.xlsx
    578.9 KB · Affichages: 36
  • Épuration des exe(2).xls
    63 KB · Affichages: 45

job75

XLDnaute Barbatruc
Re : Filtrage d'un immense fichier

Re,

Si au lieu de rechercher l'égalité on recherche les textes qui contiennent les mots du dictionnaire :

Code:
Sub Epuration_SEARCH()
Dim t#, nomfich$, a1$, a2$, f$
t = Timer
nomfich = "test.xlsx" 'nom à adapter
On Error Resume Next
If IsError(Workbooks(nomfich)) Then MsgBox "Ouvrez " & nomfich: Exit Sub
On Error GoTo 0
'---adresses à adapter---
a1 = Feuil2.[A2:A290].Address(, , xlR1C1, True)
a2 = Feuil2.[B2:B290].Address(, , xlR1C1, True)
'---formule---
f = "=LN(SUMPRODUCT(ISNUMBER(SEARCH(" & a1 & ",RC4))*(R1C4=" & a2 & ")+ISNUMBER(SEARCH(" & a1 & ",RC7))*(R1C7=" & a2 & ")))"
'---traitement du fichier---
Application.ScreenUpdating = False
With Workbooks(nomfich).Sheets(1).UsedRange
  .Columns(8).FormulaR1C1 = f 'en colonne H
  .Columns(8) = .Columns(8).Value 'ne garde que les valeurs
  'le tri place les nombres en bas du tableau (pour accélérer)
  .Resize(, 8).Sort .Columns(8), xlDescending, Header:=xlYes
  On Error Resume Next 's'il n'y a rien à supprimer
  .Columns(8).SpecialCells(xlCellTypeConstants, 1).EntireRow.Delete
  .Columns(8).Delete xlToLeft
  Application.Goto .Cells(1), True
End With
Application.ScreenUpdating = True
MsgBox "Durée " & Format(Timer - t, "0.0 \s") 'facultatif...
End Sub
L'exécution est évidemment bien plus longue : 46 secondes.

Avec cette macro seulement 8 lignes de plus que précédemment sont supprimées :

- la ligne 15228 contenant "Microsoft Office Publisher"

- les lignes 22064-22065-22066-22270-27773-27774-27775 contenant "Installer".

Fichier (3).

A+
 

Pièces jointes

  • test.xlsx
    578.9 KB · Affichages: 43
  • test.xlsx
    578.9 KB · Affichages: 61
  • test.xlsx
    578.9 KB · Affichages: 45
  • Épuration des exe(3).xls
    58.5 KB · Affichages: 38
Dernière édition:

siocnarf

XLDnaute Occasionnel
Re : Filtrage d'un immense fichier

Bonjour,

J'espère que vous avez eu du plaisir à tester cela :)

Le but étant de retirer du tableau de 400 000 lignes tout ce qui se trouve dans le dictionnaire, je dois admettre que vos macros sont bien au-delà de ce que je sais faire :).

Je comprend qu'effectivement en mettant screen updating à false on va gagner en vitesse. Pouvez-vous m'expliquer un peu le reste car cela m'intéresse.
Code:
'---formule---
 f = "=LN(SUMPRODUCT(ISNUMBER(SEARCH(" & a1 & ",RC4))*(R1C4=" & a2 & ")+ISNUMBER(SEARCH(" & a1 & ",RC7))*(R1C7=" & a2 & ")))"
 '---traitement du fichier---
 Application.ScreenUpdating = False
 With Workbooks(nomfich).Sheets(1).UsedRange
   .Columns(8).FormulaR1C1 = f 'en colonne H
   .Columns(8) = .Columns(8).Value 'ne garde que les valeurs
   'le tri place les nombres en bas du tableau (pour accélérer)
   .Resize(, 8).Sort .Columns(8), xlDescending, Header:=xlYes
   On Error Resume Next 's'il n'y a rien à supprimer
   .Columns(8).SpecialCells(xlCellTypeConstants, 1).EntireRow.Delete
   .Columns(8).Delete xlToLeft
   Application.Goto .Cells(1), True
 End With
 Application.ScreenUpdating = True
 MsgBox "Durée " & Format(Timer - t, "0.0 \s") 'facultatif...
 End Sub
 

job75

XLDnaute Barbatruc
Re : Filtrage d'un immense fichier

Re,

Si vous connaissez un peu l'anglais, vous comprendrez ce que fait chaque ligne.

Et en plus j'ai mis des commentaires.

Si vous voulez voir l'effet d'une ligne, vous intercalez un End.

A+
 

siocnarf

XLDnaute Occasionnel
Re : Filtrage d'un immense fichier

Bonsoir,

Je suis à tenter d'introduire votre code dans mon code.

a1 = Feuil2.[A2:A290].Address(, , xlR1C1, True) --> Cela fonctionne ... évidemment
D_SDictionnaireCol1 = D_VDictionnaire(0).["A2:A" & D_IntDligneExtractData].Address(, , xlR1C1, True)

Ma ligne retourne un "objet requis".
D_VDictionnaire(0) = "Feuil2"
D_IntDligneExtractData = 290

Je manque où et quoi?

Merci,

François
 

siocnarf

XLDnaute Occasionnel
Re : Filtrage d'un immense fichier

Bonjour,

J'aurais besoin d'une précision:

Les valeurs recherchées se retrouvent dans les colonnes 4,6 et 7. Est-ce que le code ci-dessous vérifie les colonnes 4 à 7 ou si elles ne couvre que les colonnes 4 et 7?

Code:
"=LN(SUMPRODUCT(ISNUMBER(SEARCH(" & a1 & ",RC4))*(R1C4=" & a2 & ")+ISNUMBER(SEARCH(" & a1 & ",RC7))*(R1C7=" & a2 & ")))"

Merci,

François
 

job75

XLDnaute Barbatruc
Re : Filtrage d'un immense fichier

Bonjour siocnarf,

La formule est claire : seules les colonnes 4 et 7 sont analysées.

Pour terminer voici une solution très simple et très facile à comprendre :

Code:
Sub Epuration()
Dim t#, nomfich$, c As Range
t = Timer
nomfich = "test.xlsx" 'nom à adapter
On Error Resume Next
If IsError(Workbooks(nomfich)) Then MsgBox "Ouvrez " & nomfich: Exit Sub
On Error GoTo 0
Application.ScreenUpdating = False
With Workbooks(nomfich).Sheets(1).UsedRange
  For Each c In Feuil2.Range("A2", Feuil2.Range("A" & Feuil2.Rows.Count).End(xlUp))
    .Columns(c(1, 2)).Replace "*" & c & "*", "#N/A"
  Next
  On Error Resume Next 's'il n'y a pas de valeur d'erreur
  .SpecialCells(xlCellTypeConstants, 16).EntireRow.Delete
  Application.Goto .Cells(1)
End With
Application.ScreenUpdating = True
MsgBox "Durée " & Format(Timer - t, "0.0 \s") 'facultatif...
End Sub
La macro s'exécute chez moi en 16 secondes, sur 400000 lignes on devrait atteindre 208 secondes.

En 2ème colonne du dictionnaire j'ai mis les numéros des colonnes à traiter, il pourrait y en avoir d'autres que les colonnes 4 et 7.

Fichier (4).

A+
 

Pièces jointes

  • test.xlsx
    578.9 KB · Affichages: 44
  • test.xlsx
    578.9 KB · Affichages: 32
  • test.xlsx
    578.9 KB · Affichages: 33
  • Épuration des exe(4).xls
    62 KB · Affichages: 31
Dernière édition:

siocnarf

XLDnaute Occasionnel
Re : Filtrage d'un immense fichier

Bonjour,

J'ai exécuté votre 3e test avec visant un contenu et cela s'est déroulé en 23,6 secondes. Sur 40 000 lignes. Donc on peut s'attendre à 4 minutes ce qui est très acceptable.

Vous êtes très fort. En relisant votre code initiale, je me demandais, dans le fond, si la colonne 2 était utile. En effet, dans le code initiale, nous chargions le tout dans deux variables (l'une pour la colonne a et l'autre pour la colonne B) toutefois la totalité des mots est recherché dans les colonnes 4 et 7 indifféremment de l'information dans la colonne 2).

Par exemple, dans la colonne A on retrouve Microsoft Office Upload Center
Dans la colonne B on retrouvait: Description

Donc logiquement on aurait dû chercher le premier terme dans la colonne B. Mais votre code initial faisait une recherche plus large. Est-ce que cela change quelque chose? Pas sur, je crois que votre proposition est juste.

Je vais prendre le temps d'examiner et tester votre dernier code mais il semble intéressant.

Encore une fois merci!
 

job75

XLDnaute Barbatruc
Re : Filtrage d'un immense fichier

Re,

Sur 400000 lignes la suppression des lignes peut prendre du temps.

Comme dans les versions (1) à (3) on peut faire un tri pour accélérer :

Code:
Sub Epuration()
Dim t#, nomfich$, c As Range
t = Timer
nomfich = "test.xlsx" 'nom à adapter
On Error Resume Next
If IsError(Workbooks(nomfich)) Then MsgBox "Ouvrez " & nomfich: Exit Sub
On Error GoTo 0
Application.ScreenUpdating = False
With Workbooks(nomfich).Sheets(1).UsedRange
  For Each c In Feuil2.Range("A2", Feuil2.Range("A" & Feuil2.Rows.Count).End(xlUp))
    .Columns(c(1, 2)).Replace "*" & c & "*", "#N/A"
  Next
  .Columns(8) = 0 'colonne H
  On Error Resume Next 's'il n'y a pas de valeur d'erreur
  Intersect(.SpecialCells(xlCellTypeConstants, 16).EntireRow, .Columns(8)) = "#N/A"
  'le tri place les #N/A en bas du tableau (pour accélérer la suppression)
  .Resize(, 8).Sort .Columns(8), xlAscending, Header:=xlYes
  .Columns(8).SpecialCells(xlCellTypeConstants, 16).EntireRow.Delete
  .Columns(8).Delete xlToLeft
  Application.Goto .Cells(1)
End With
Application.ScreenUpdating = True
MsgBox "Durée " & Format(Timer - t, "0.0 \s") 'facultatif...
End Sub
Fichier (4 bis).

A+
 

Pièces jointes

  • test.xlsx
    578.9 KB · Affichages: 40
  • test.xlsx
    578.9 KB · Affichages: 41
  • test.xlsx
    578.9 KB · Affichages: 38
  • Épuration des exe(4 bis).xls
    63.5 KB · Affichages: 45
Dernière édition:

siocnarf

XLDnaute Occasionnel
Re : Filtrage d'un immense fichier

Bonjour,

Vous croyez que la vitesse d'exécution ne sera pas linéaire?
Votre dernier code ne fonctionne pas.
Erreur 1004 sur "For Each c In Feuil2.Range("A2", Range("A" & Rows.Count).End(xlUp))"

Merci,

François
 

Discussions similaires

Réponses
2
Affichages
296
  • Question
Microsoft 365 Code VBA
Réponses
10
Affichages
704
Réponses
12
Affichages
462

Statistiques des forums

Discussions
314 656
Messages
2 111 609
Membres
111 221
dernier inscrit
Odré