VBA recherche dans un fichier .txt

bonjour Kilian, X Cellus, le fil,

si on le fait en 2 étapes et la première est : on écrit tout le fichier TXT vers une feuille auxiliaire en colonnes.

Cela prend combien de temps ?

  Sub Search_TextFile()
     Dim Nom, FileNo, A, i, TextData, Fl, Demande, Result, Out
     Nom = ThisWorkbook.Path & "\Items-1011.txt"
     If vbYes <> MsgBox("c'est le " & Nom & "???", vbYesNo, UCase("quel fichier")) Then
          Nom = ChoisirFichier(".txt", ActiveWorkbook.Path)
     End If
     If Nom = "" Then Exit Sub

     t0 = Timer
     Application.ScreenUpdating = False
     FileNo = FreeFile     'premier numero libre
     Open Nom For Input As #FileNo
     TextData = Split(Input$(LOF(FileNo), FileNo), vbCrLf)     'vers une matrice et séparer sur le CarriageReturnLineFeed
     Close #FileNo     'fermer TXT

     t1 = Timer

     ReDim Out(1 To UBound(TextData) + 1, 1 To 1)
     For i = 0 To UBound(TextData)
          Out(i + 1, 1) = TextData(i)
     Next

     With Sheets("Teste")
          .Cells.ClearContents
          With .Range("A2").Resize(UBound(Out))
               .Value = Out     's'il y en a, copier vers (pour le moment) feuille "Teste"
               .TextToColumns Destination:=.Range("A1"), DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, Semicolon:=False, Comma:=False, Space:=False, Other:=False, DecimalSeparator:=".", ThousandsSeparator:=","     ', 'TrailingMinusNumbers:=True, FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), Array(7, 1), Array(8, 1), Array(9, 1), Array(10, 1), Array(11, 1), Array(12, 1), Array(13, 1))
          End With
     End With

     Application.ScreenUpdating = True
     DoEvents

     T2 = Timer

     MsgBox "nombre de records " & UBound(Out) & vbLf & "temps d'exécution : " & Format(T2 - t0, "0.00\s") & vbLf & "Lire le fichier TXT : " & Format(t1 - t0, "0.00\s") & vbLf & "Ecrire en colonnes vers feuille : " & Format(T2 - t1, "0.00")

End Sub

Function ChoisirFichier(ByVal strExtension As String, Optional ByVal strChemin As String = "") As String
     ' Choix d'un fichier
     ' 17/12/19 Patrice33740 V1-0-00
     '
     Dim dlgParcourir As FileDialog    'boite de dialogue fichiers

     'Repertoire par défaut : celui de cette macro
     If strChemin = "" Then strChemin = ThisWorkbook.Path
     'Créer une boite de dialogue Parcourir fichier
     Set dlgParcourir = Application.FileDialog(msoFileDialogFilePicker)
     'Selectionner le fichier
     With dlgParcourir
          .InitialFileName = strChemin
          .Title = "Sélectionner un fichier " & strExtension & " :"
          .AllowMultiSelect = False
          .InitialView = msoFileDialogViewDetails
          .ButtonName = "Sélection fichier"
          If .Filters.Count > 0 Then .Filters.Delete
          .Filters.Add "Fichiers " & strExtension, "*" & strExtension, 1
          If .Show = -1 Then ChoisirFichier = .SelectedItems(1) Else ChoisirFichier = ""
     End With
     Set dlgParcourir = Nothing

End Function

     

bonjour le fil,

le temps de filtrer, copier et coller les données (qui sont déjà importé) est dans mon modèle de 1.000.000 lignes * 20 colonnes, où on doit copier toutes les lignes impaires (donc la moitié) est 30 sec (10 sec pour préparer les formules pour savoir quelles lignes on veut copier) et 20 sec pour le colle.

Hello,

Merci à tout le monde pour l'aide que vous m'avez apporté.
J'ai donc bien ce que je voulais avec le code de BsAlv. Le voici :

Sub Search_TextFile()
     Dim Nom, FileNo, A, i, TextData, Fl, Demande, Result, Out

     Nom = "mon_chemin_fichier.txt"

     t0 = Timer
     Application.ScreenUpdating = False

     '***********************ADOB*********************************************************
     'ensure reference is set to Microsoft ActiveX DataObjects library (the latest version of it).
     'under "tools/references"... references travel with the excel file, so once added, no need to worry.
     'if not you will get a type mismatch / library error on line below.

     Dim Adostream As ADODB.Stream
     Dim var_String As Variant

     Set Adostream = New ADODB.Stream

     Adostream.Charset = "UTF-8"
     Adostream.Open
     Adostream.LoadFromFile Nom    'change this to point to your text file
     TextData = Split(Adostream.ReadText, vbCrLf)     'split entire file into array - lines delimited by CRLF

     t1 = Timer

     ReDim Out(1 To UBound(TextData) + 1, 1 To 1)
     For i = 0 To UBound(TextData)
          Out(i + 1, 1) = TextData(i)
     Next

     With Sheets("BDD")
     Application.DisplayAlerts = False
        If Not .Cells(1, 1) = Date Then
          .Range("C2:M60000").ClearContents
          With .Range("B2").Resize(UBound(Out))
               .Value = Out     's'il y en a, copier vers la feuille BDD
               .TextToColumns Destination:=.Range("A1"), DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, Semicolon:=False, Comma:=False, Space:=False, Other:=False, DecimalSeparator:=".", ThousandsSeparator:=","     ', 'TrailingMinusNumbers:=True, FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), Array(7, 1), Array(8, 1), Array(9, 1), Array(10, 1), Array(11, 1), Array(12, 1), Array(13, 1))
          End With
          .Cells(1, 1) = Date
        End If
    Application.DisplayAlerts = True
     End With

     Application.ScreenUpdating = True
     DoEvents

     t2 = Timer

     MsgBox "nombre de records " & UBound(Out) & vbLf & "temps d'exécution : " & Format(t2 - t0, "0.00\s") & vbLf & "Lire le fichier TXT : " & Format(t1 - t0, "0.00\s") & vbLf & "Ecrire en colonnes vers feuille : " & Format(t2 - t1, "0.00")
End Sub

Je garde toutes vos réponses et solutions qui me seront bien utile en temps voulu !

Sujet désormais clos.

A+,
Kilian