XL 2016 Import Txt volumineux

[auverland]

Bonjour le forum

J'ai parcouru le forum mais j'ai pas retrouvé le script qui permet l'importation de fichier txt volumineux sur plusieurs feuilles tout en gardant les entêtes sur chacune des feuilles. (séparateur ";")

Si vous aviez cela dans votre armoire je suis preneur
Bonne journée

 

[sylvanu]

Bonjour Auverland,
Qu'appelez vous volumineux ?
XL2016 possède 1 048 576 lignes et 16 384 colonnes sur une feuille. Votre fichier ne rentre pas dedans ?

 

[auverland]

Bonjour Auverland,
Qu'appelez vous volumineux ?
XL2016 possède 1 048 576 lignes et 16 384 colonnes sur une feuille. Votre fichier ne rentre pas dedans ?

Bonjour,

Mon fichier fait 171000Ko avec 10 variables (colonne)
Lorsque je l'importe il me met effectivement que je dépasse la capacité excel
J'avais vue une fois un script qui coupait le fichier en plusieurs feuille mais impossible de remettre la main dessus

 

[sylvanu]

Ouf ! J'espère que qulqu'un pourra vous aider, mais le problème est vraiment pointu.

 

[auverland]

Ouf ! J'espère que qulqu'un pourra vous aider, mais le problème est vraiment pointu.

J'ai trouvé cela qui fonctionnerais en adaptant le séparateur en ";"

Sub Extraction_V2()
Dim Repertoire As String, Fichier As String
Dim strFullName As Variant
Dim Cn As Object, Rs As Object
 
'Sélection du ficher
strFullName = Application.GetOpenFilename("Fichiers textes (*.txt),*.txt", , _
    "Sélectionnez un fichier :")
 
'On sort si aucun fichier n'est sélectionné
If strFullName = False Then Exit Sub
 
Application.ScreenUpdating = False
Fichier = Dir(strFullName)
Repertoire = Left(strFullName, Len(strFullName) - (Len(Fichier) + 1))
 
 
'Connection
Set Cn = CreateObject("ADODB.Connection")
Cn.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
    "Data Source=" & Repertoire & ";" & _
    "Extended Properties=""text;HDR=Yes;FMT=Delimited"""
 
'Requete
Set Rs = CreateObject("ADODB.Recordset")
Rs.Open "SELECT * FROM [" & Fichier & "]", Cn, 3, 1, 1
 
'boucle sur le résultat de la requete
While Not Rs.EOF
    'Ajout Feuille
    Worksheets.Add
    'Ecriture des données dans la feuille
    '65536 spécifie le nombre de lignes par feuille
    ActiveSheet.Range("A1").CopyFromRecordset Rs, 65536
Wend
 
Rs.Close
Set Rs = Nothing
Cn.Close
Set Cn = Nothing
Application.ScreenUpdating = True
End Sub

 

[riton00]

Bonjour

Un essais avec une macro que j'ai trouvé dans mes archives (limite à 65000 ligne)

Sub GrosFichierTXT()
Dim Ctr As Long, Ligne As String, Tablo, x As Integer
Application.ScreenUpdating = False
Ctr = 1
Open "D:\répertoire\sous-répertoire\fichier.txt" For Input As #1
Do While Not EOF(1)
If Ctr > 65000 Then
Ctr = 1
Sheets.Add
End If
Line Input #1, Ligne
Tablo = Split(Ligne, ";")
For x = 0 To UBound(Tablo)
Cells(Ctr, x + 1) = Tablo(x)
Next x
Ctr = Ctr + 1
Loop
Close #1
Application.ScreenUpdating = True
End Sub

Slts

 

[ThierryP]

Bonjour,

J'ai remis la main sur une procédure du grand Frédéric Sigonneau, adpatée d'un MVP dont j'ai oublié le nom !
ça donne ceci (à noter que le nombre maxi est à 65500, c'est dire si c'est ancien !!!)
'##############################
Sub ImportLargefile()
'Dimension Variables
Dim ResultStr As String
Dim FileName As String
Dim FileNum As Integer
Dim Counter As Double
FileName = "C:\Temp\yourfile.txt"
'If you want an inputbox use the below:
'InputBox("Write name of file and path")
If FileName = "" Then End
FileNum = FreeFile()
Open FileName For Input As #FileNum
Application.ScreenUpdating = False
Workbooks.Add template:=xlWorksheet
Counter = 1
Do While Seek(FileNum) <= LOF(FileNum)
Application.StatusBar = "Importerar Rad " & _
Counter & " Från TextFil " & FileName
Line Input #FileNum, ResultStr
If Left(ResultStr, 1) = "=" Then
ActiveCell.Value = "'" & ResultStr
Else
ActiveCell.Value = ResultStr
End If
If ActiveCell.Row = 65500 Then
' I'll need some space below
'If file is larger than (Ce lien n'existe plus)
ActiveWorkbook.Sheets.Add
Else
ActiveCell.Offset(1, 0).Select
End If
Counter = Counter + 1
Loop
Close
Application.StatusBar = False
End Sub
'################################
En espérant que ça aide !

ThierryP

 

[ThierryP]

Bon ben j'ai dégainé le dernier...

 

[job75]

Bonjour auverland, le fil,

Le séparateur point-virgule c'est sur les fichiers CSV, les fichiers Texte (.txt) utilisent le caractère tabulation comme séparateur.

La lecture séquentielle d'un fichier texte et le transfert des données sont très rapides, voyez les fichiers joints et cette macro :

Sub Import()
Dim fichier$, nlig&, ncol%, w As Worksheet, a(), texte$, s, i&, j%, n&
fichier = ThisWorkbook.Path & "\Fichier Texte.txt" 'à adapter
nlig = 100 '1048576
ncol = 10 'nombre maximum de colonnes
'---suppression des feuilles---
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each w In Worksheets
    If w.Index > 1 Then w.Delete
Next w
Worksheets(1).Cells.ClearContents 'RAZ
'---traitement séquentiel du fichier Texte et transferts---
ReDim a(1 To nlig, 1 To ncol)
Open fichier For Input As #1 'accès au fichier
Do While Not EOF(1) 'End Of File: fin du fichier
    Line Input #1, texte 'récupère la ligne
    s = Split(texte, vbTab) 'séparateur tabulation
    i = i + 1
    For j = 0 To UBound(s)
        a(i, j + 1) = s(j)
    Next j
    If i = nlig Then 'décharge
        If n Then Set w = Sheets.Add(After:=Sheets(Sheets.Count)) Else Set w = Worksheets(1)
        n = n + 1
        w.Name = "Import " & n
        w.Cells(1).Resize(nlig, ncol) = a
        w.Columns.AutoFit 'ajustement largeurs
        ReDim a(1 To nlig, 1 To ncol)
        i = 0
    End If
Loop
Close #1 'fermeture du fichier
'---dernier transfert
If i Then
    If n Then Set w = Sheets.Add(After:=Sheets(Sheets.Count)) Else Set w = Worksheets(1)
    n = n + 1
    w.Name = "Import " & n
    w.Cells(1).Resize(i, ncol) = a
    w.Columns.AutoFit 'ajustement largeurs
End If
Worksheets(1).Activate
End Sub

Bien entendu j'ai mis nlig = 100 pour tester, avec le très gros fichier on mettra nlig = 1048576.

A+

 

[auverland]

Bonjour auverland, le fil,

Le séparateur point-virgule c'est sur les fichiers CSV, les fichiers Texte (.txt) utilisent le caractère tabulation comme séparateur.

La lecture séquentielle d'un fichier texte et le transfert des données sont très rapides, voyez les fichiers joints et cette macro :

Bonsoir @job75

Mes fichiers sont en txt avec des séparateurs en point-virgule
Vue la taille des fichier je peux meme pas les remplacer

 

[job75]

Il manquait le traitement des en-têtes de colonnes, ce fichier (2) les place sur toutes les feuilles créées.

 

[job75]

Pour tester j'ai créé un fichier Texte de 1048576 lignes x 10 colonnes qui pèse 91 Mo.

Avec nlig = 1048576 ma macro s'exécute chez moi en 15 secondes environ.

 

[job75]

Bonjour auverland, le forum,

Si vous tenez au point-virgule comme séparateur dans le fichier Texte vous pouvez remplacer les tabulations avec cette macro :

Sub RemplacerTabulation()
Dim fichier$, texte$, a$(), i&
fichier = ThisWorkbook.Path & "\Fichier Texte.txt" 'à adapter
Open fichier For Input As #1 'accès au fichier en lecture
Do While Not EOF(1) 'End Of File: fin du fichier
    Line Input #1, texte 'récupère la ligne
    ReDim Preserve a(i)
    a(i) = Replace(texte, vbTab, ";")
    i = i + 1
Loop
Close #1
Open fichier For Output As #1 'accès au fichier en écriture
For i = 0 To UBound(a)
    Print #1, a(i)
Next
Close #1
End Sub

Ensuite bien sûr dans la macro Import remplacer vbTab par ";" :

s = Split(texte, ";") 'séparateur point-virgule

Bonne journée.