Optimisation macro recherche dans un fichier texte

Le 28/09/2017 à 16:05

Bonjour,

J'ai réalisé une macro qui récupérée une valeur dans un fichier xls et cherche cette valeur dans un fichier texte, une fois trouver je copie la ligne et la ligne suivante du fichier texte. Par contre il faut que la macro tourne pendant 30min pour traitement 9000 cellules.

Je souhaite savoir s'il y a un moyen pour optimiser la recherche.

Merci d'avance

Cf-code

Sub recherche()

Dim strLigne As String

Dim findval As String

Dim i As Integer

For i = 1 To 9000

Open "C:\bluebook2.txt" For Input As #1

findval = Cells(i, 1).Value 'recupperation de l'information à chercher

Do While Not EOF(1)

Line Input #1, strLigne 'lecture du fichier bluebook2 ligne par ligne

If InStr(1, strLigne, findval, 1) > 0 Then 'condition si l'information trouvé

Cells(i, 2) = strLigne 'copier la ligne en cours de lecture

Line Input #1, strLigne 'lecture de la ligne suivante

Cells(i, 3) = strLigne 'copier la ligne suivante

End If

Loop

Close #1

Next i

MsgBox "traitement terminer"

End Sub

Le 30/09/2017 à 22:27

Bonsoir,

un petit up afin de proposer une solution que je ne maitrise pas :

Si le contenu du fichier est "mis" dans une variable tableau VBA

Si le contenu des 9000 lignes est "mis" dans un tableau VBA

la recherche et comparaison sera plus rapide, et si le résultat de la recherche est "mis" dans un tableau

Si à l'issue de la recherche le tableau est coller sur une feuille

Si tout ceci est possible alors cela devrait être plus rapide, non ?

@ bientôt

LouReeD

Le 01/10/2017 à 04:03

Bonjour

Une proposition "à la va-vite" parce que sans fichier exemple ce n'est pas évident de se faire une idée correcte et qui suit exactement la réflexion (très judicieuse ) de LouReed

En fait même 2 propositions par rapidité croissante, avec quelques conseils de "code lisible" en prime :

'Sub recherche()            <== toujours une majuscule dans les noms ainsi la verification des saisies est plus facile
Sub RechercheUnPlusRapide()

Dim strLigne As String
'Dim findval As String      <== toujours une majuscule dans les noms ainsi la verification des saisies est plus facile
'Dim i As Integer           <== jamais de i,j,k ce ne sont que des variables qui ne veulent rien dire (en VBA en tout cas)
Dim findVal As String
Dim cptCel                  '   <=== ici on sait automatiquement sur quoi on travaille !

Dim tabCelArcup()

    tabCelArcup = Range(Cells(1, 1), Cells(9000, 3))

    'For i = 1 To 9000
    For cptCel = 1 To UBound(tabCelArcup, 1)
        Open "C:\bluebook2.txt" For Input As #1
            'findval = Cells(i, 1).Value 'recupperation de l'information à chercher
            findVal = tabCelArcup(cptCel, 1)
            Do While Not EOF(1)
                Line Input #1, strLigne 'lecture du fichier bluebook2 ligne par ligne

                If InStr(1, strLigne, findVal, 1) > 0 Then 'condition si l'information trouvé
                    'Cells(i, 2) = strLigne 'copier la ligne en cours de lecture
                    'Line Input #1, strLigne 'lecture de la ligne suivante
                    'Cells(i, 3) = strLigne 'copier la ligne suivante
                    tabCelArcup(cptCel, 2) = strLigne
                    Line Input #1, strLigne
                    tabCelArcup(cptCel, 3) = strLigne
                End If
            Loop
        Close #1
    Next i

    'MsgBox "traitement terminer"
    Cells(1, 1).Resize(UBound(tabCelArcup, 1), UBound(tabCelArcup, 2)) = tabCelArcup
    MsgBox "traitement terminé"

End Sub
Sub RechercheEncorePlusRapide()
Dim strLigne As String
Dim findVal As String
Dim cptCel
Dim nbrLig

Dim tabCelArcup()
Dim tabFicAlire()

    nbrLig = 1
    ReDim tabFicAlire(1 To nbrLig)
    Open "C:\bluebook2.txt" For Input As #1
        ReDim Preserve tabFicAlire(1 To nbrLig)
        While Not EOF(1)
            Line Input #1, strLigne
            tabFicAlire(nbrLig) = strLigne
            nbrLig = nbrLig + 1
        Wend
    Close #1

    tabCelArcup = Range(Cells(1, 1), Cells(9000, 3))
    For cptCel = 1 To UBound(tabCelArcup, 1)
        posfic = TrouveDansFic(tabFicAlire, tabCelArcup(cptCel, 1))
        If posfic > 0 Then
            tabCelArcup(cptCel, 2) = tabFicAlire(posfic)
            tabCelArcup(cptCel, 3) = tabFicAlire(posfic + 1)
        End If
    Next

    Cells(1, 1).Resize(UBound(tabCelArcup, 1), UBound(tabCelArcup, 2)) = tabCelArcup
    MsgBox "traitement terminé"

End Sub

Function TrouveDansFic(tabloFic, quoi)
Dim trvFic As Boolean
Dim cptFic

    trvFic = False
    cptFic = 1
    While Not (cptFic > UBound(tabloFic, 1)) And Not trvFic
        If InStr(1, tabloFic(cptFic), quoi, 1) > 0 Then
            trvFic = True
        Else
            cptFic = cptFic + 1
        End If
    Wend

    If trvFic Then
        TrouveDansFic = cptFic
    Else
        TrouveDansFic = -1
    End If

End Function
Le 01/10/2017 à 09:29

Bonjour,

à ce que je vois il ne me reste plus qu'à savoir "écrire" ce que je pense pour être un "pro" du VBA !

Je ne regrette pas d'avoir fait un "Up" du message

Merci pour lui NCC 1701.

@ bientôt

LouReeD

Le 01/10/2017 à 10:46

Merci pour la solution je vais tester. ci-joint un exemple de mon fichier simplifié.

Sachant que j'ai plus de 100000 ligne de fichier texte et 25100 variables à chercher à partir d'un fichier texte.

111exemple-fichier-txt.txt (674.00 Octets)
117macro3.xlsm (171.53 Ko)
Le 01/10/2017 à 10:47

@LouReed

LouReeD a écrit :

à ce que je vois il ne me reste plus qu'à savoir "écrire" ce que je pense pour être un "pro" du VBA

tu vas me faire

Mais attendons de voir ce qu'en penses nelamari

Le 01/10/2017 à 13:54

dans ce code j'ai un plantage si:

Sub RechercheEncorePlusRapide()

Dim strLigne As String

Dim findVal As String

Dim cptCel

Dim nbrLig

Dim tabCelArcup()

Dim tabFicAlire()

nbrLig = 1

ReDim tabFicAlire(1 To nbrLig)

Open "C:\bluebook2.txt" For Input As #1

ReDim Preserve tabFicAlire(1 To nbrLig)

While Not EOF(1)

Line Input #1, strLigne

tabFicAlire(nbrLig) = strLigne

nbrLig = nbrLig + 1

Wend

Close #1

tabCelArcup = Range(Cells(1, 1), Cells(9000, 3))

For cptCel = 1 To UBound(tabCelArcup, 1)

posfic = TrouveDansFic(tabFicAlire, tabCelArcup(cptCel, 1))

If posfic > 0 Then

tabCelArcup(cptCel, 2) = tabFicAlire(posfic)

tabCelArcup(cptCel, 3) = tabFicAlire(posfic + 1)

End If

Next

Cells(1, 1).Resize(UBound(tabCelArcup, 1), UBound(tabCelArcup, 2)) = tabCelArcup

MsgBox "traitement terminé"

End Sub

Function TrouveDansFic(tabloFic, quoi)

Dim trvFic As Boolean

Dim cptFic

trvFic = False

cptFic = 1

While Not (cptFic > UBound(tabloFic, 1)) And Not trvFic

If InStr(1, tabloFic(cptFic), quoi, 1) > 0 Then

trvFic = True

Else

cptFic = cptFic + 1

End If

Wend

If trvFic Then

TrouveDansFic = cptFic

Else

TrouveDansFic = -1

End If

End Function

Le 01/10/2017 à 14:51

Bonjour

Désolé !

Une erreur c'est glissée avec méchanceté sans mon code

En fait il fallait écrire

    nbrLig = 1
    ReDim tabFicAlire(1 To nbrLig)
    Open ActiveWorkbook.Path & "\exemple_fichier_txt.txt" For Input As #1
        While Not EOF(1)
            Line Input #1, strLigne
            ReDim Preserve tabFicAlire(1 To nbrLig)
            tabFicAlire(nbrLig) = strLigne
            nbrLig = nbrLig + 1
        Wend
    Close #1

et non cela :

    nbrLig = 1
    ReDim tabFicAlire(1 To nbrLig)
    Open ActiveWorkbook.Path & "\exemple_fichier_txt.txt" For Input As #1
        ReDim Preserve tabFicAlire(1 To nbrLig)     ' <=== cette ligne doit être
        While Not EOF(1)
            Line Input #1, strLigne
                                                    ' <=== ici entre le line input... et le tabFicAlire...
            tabFicAlire(nbrLig) = strLigne
            nbrLig = nbrLig + 1
        Wend
    Close #1

j'espère que vous ne m'en tiendrez pas rigueur et le commentaire de LouReed reste toujours valable

Néanmoins, je prends à ma défense que lire du code

  • non indenté
  • non mise en forme
  • sans fichier exemple pour comprendre ce que l'on fait
et par conséquent pondre le code
  • de mémoire
  • à l'aveugle
devrait me permettre de conserver le commentaire à mon avantage
Le 01/10/2017 à 16:37

merci c'est vraiment mieux, merci encore

Le 01/10/2017 à 17:50

(re)

nelamari a écrit :

merci c'est vraiment mieux, merci encore

Merci à toi pour ces Mercis
Le 01/10/2017 à 20:57

Alors là je ne suis plus !

mais mercis de vos mercis respectifs !!!!

@ bientôt

LouReeD

Rechercher des sujets similaires à "optimisation macro recherche fichier texte"