Couper un fichier txt en plusieurs fichiers

**alainb** · 24/10/2010, 11h47

Bonjour,
J'ai adapté le code trouvé dans la FAQ
Comment importer dans Excel des fichiers txt contenant plus de 65536 lignes ?
pour répondre au besoin suivant :
séparer le fichier source en X fichiers de 1000 lignes sans modifier le contenu des lignes.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
Sub test()
        Extraction cheminComplet, 1000
End sub
 
Sub Extraction(Fichier As String, NbLignesParFeuille As Long)
 
    Dim Wb As Workbook
    Dim Counter As Double
    Dim i As Integer
    Dim ContenuLigne As String
 
    Application.ScreenUpdating = False
 
    Counter = 1
 
    numFile = FreeFile
 
    Set Wb = Workbooks.Add(numFile)
 
    'Ouverture du fichier txt
    Open Fichier For Input As #numFile
 
    Do While Not EOF(numFile)
 
 
            If Counter > NbLignesParFeuille Then
 
                    Windows("Feuil" & numFile).Activate
                    Range("A1:A998").Select
                    Selection.Copy
                    Application.CutCopyMode = False
                    ActiveWorkbook.SaveAs Filename:= _
                        nomChemin & "\coupe" & numFile & ".txt", _
                        FileFormat:=xlUnicodeText, _
                        CreateBackup:=False
 
                Counter = 1
 
            End If
 
            Line Input #numFile, ContenuLigne
            ActiveSheet.Cells(Counter, 1) = ContenuLigne
            Counter = Counter + 1
        Loop
 
    Close #numFile
 
    Application.ScreenUpdating = True
    MsgBox "Opération terminée, nombre de lignes = " & Counter
    End
End Sub

Mes questions :

Je rencontre un problème d'indice avec "numFile";
A l'exécution de la macro, "Feuil" & numFile n'est pas identique au nom de la feuille ouverte par Set Wb = Workbooks.Add(numFile)
Pouvez-vous localiser mon problème ?
Est-il possible de séparer le fichier sans écrire, copier coller les lignes dans une feuille Excel ?

Alain

**helas** · 24/10/2010, 21h41

Bonjour,
numFile = Freefile est aléatoire, il suffit donc de forcer numfile = 1
et d'incrémenter pour la feuille suivante.
Il est toujours possible de scinder le fichier texte mais avec du code et toujours avec lecture et ecriture du fichier

**PMO2017** · 24/10/2010, 23h08

Bonjour,

J'ai réécris votre code. Le voici ci-dessous

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
'### Constante à adapter ###
Const FICHIER_TXT As String = "c:\gros.txt"
'###########################
 
Sub test()
Extraction FICHIER_TXT, 1000
End Sub
 
Sub Extraction(Fichier As String, NbLig As Long)
Dim WB As Workbook
Dim S As Worksheet
Dim cpt&
Dim numFile&
Dim A$
Dim T()
Dim T2()
Dim ShCount&
Dim i&
Dim j&
Dim k&
Dim deb&
Dim alerte$
i& = FreeFile
Open Fichier For Input As #i&
  Do While Not EOF(i&)
    cpt& = cpt& + 1
    Line Input #i&, A$
    ReDim Preserve T(1 To 1, 1 To cpt&)
    T(1, cpt&) = A$
  Loop
Close #i&
With Application
  ShCount& = .SheetsInNewWorkbook
  .SheetsInNewWorkbook = .WorksheetFunction.RoundUp(cpt& / NbLig, 0)
  Set WB = Workbooks.Add
  .SheetsInNewWorkbook = ShCount&
End With
deb& = 1
For i& = 1 To WB.Sheets.Count
  If i& * NbLig > cpt& Then
    NbLig = cpt& - (NbLig * (i& - 1))
  End If
  ReDim T2(1 To NbLig, 1 To 1)
  Set S = WB.Sheets(i&)
  k& = 0
  For j& = deb& To deb& + NbLig - 1
    k& = k& + 1
    If Len(T(1, j&)) > 900 Then
      T2(k&, 1) = "'" & Left(T(1, j&), 900)
      alerte$ = vbCrLf & vbCrLf & _
        "ATTENTION : Des lignes comportant plus de 900 caractères ont été limitées à 900 caractères"
    Else
      T2(k&, 1) = "'" & T(1, j&)
    End If
  Next j&
  S.Range("a1:a" & NbLig & "") = T2
  deb& = deb& + NbLig
Next i&
MsgBox "Opération terminée, nombre de lignes = " & cpt& & vbCrLf & vbCrLf & _
  "Toutes les lignes ont été quotées (') pour éviter les interprétations de formule" _
  & alerte$
End Sub

Après plusieurs tests à partir d'un gros fichier sur ma machine, j'ai pu constater les choses suivantes
1) Excel semble limiter le nombre de caractères dans une cellule si bien que j'ai fixé un plafond de 900 caractères
2) Un bug survenait systématiquement et j'en ai déduit qu'il devait y avoir une interprétation d'une formule Excel
suite au 1er caractère de la ligne (= * + etc). J'ai donc ajouté une quote ( ' ) au début de chaque ligne

Cordialement.

PMO
Patrick Morange

**alainb** · 29/10/2010, 17h58

Merci Patrick,
Ton code fonctionne au poil

J'ai travaillé une variante.
Le contenu n'est pas partagé dans les feuilles d'un nouveau classeur, mais copié dans des fichiers texte.

Dans le fichier texte, le contenu de chaque ligne est précédé et suivi d'un guillemet.
Comment copier ma variable sans les écrire ?
Alain

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
 
Sub ExtractionNew(Fichier As String, NbLig As Long)
 
    Dim WB As Workbook
    Dim S As Worksheet
    Dim cpt&
    Dim numFile&
    Dim A$
    Dim T()
    Dim T2()
    Dim ShCount&
    Dim i&
    Dim j&
    Dim k&
    Dim deb&
    Dim alerte$
    i& = FreeFile
 
    'ouvrir et lire le contenu du fichier source
    Open Fichier For Input As #i&
        Do While Not EOF(i&)
            cpt& = cpt& + 1
            Line Input #i&, A$
            ReDim Preserve T(1 To 1, 1 To cpt&)
            T(1, cpt&) = A$
        Loop
    Close #i&
 
    'calculer le nombre de feuilles à ajouter dans le classeur
    nbFeuille = WorksheetFunction.RoundUp(cpt& / NbLig, 0)
 
    'séparer le contenu du fichier source dans les feuilles
    deb& = 1
    For i& = 1 To nbFeuille
        If i& * NbLig > cpt& Then
          NbLig = cpt& - (NbLig * (i& - 1))
        End If
 
        ReDim T2(1 To NbLig, 1 To 1)
 
        k& = 0
        For j& = deb& To deb& + NbLig - 1
 
            k& = k& + 1
            If Len(T(1, j&)) > 900 Then
                T2(k&, 1) = "'" & Left(T(1, j&), 900)
                alerte$ = vbCrLf & vbCrLf & _
                  "ATTENTION : Des lignes comportant plus de 900 caractères ont été limitées à 900 caractères"
            Else
 
                If Len(T(1, j&)) > temp Then
                    temp = Len(T(1, j&))
                End If
 
                T2(k&, 1) = T(1, j&)
            End If
        Next j&
 
        deb& = deb& + NbLig
 
        'ouvrir et écrire le contenu de la feuille dans un fichier texte
        cptLig& = 0
        Open chemin & "\coupe" & i& & ".txt" For Output As #i&
            Do
                cptLig& = cptLig& + 1
                A$ = T2(cptLig&, 1)
                Write #i&, A$
            Loop While cptLig& < NbLig
            Write #i&, "—RECAPITULATION" 'drapeau de fin de fichier
        Close #i&
 
    Next i&
 
End Sub

**alainb** · 29/10/2010, 18h08

J'ai trouvé la solution, remplacer Write par Print
Merci à tous
Alain

**PMO2017** · 29/10/2010, 18h24

Bonjour,

Remplacez

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
            Do
                cptLig& = cptLig& + 1
                A$ = T2(cptLig&, 1)
                Write #i&, A$
            Loop While cptLig& < NbLig

par

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
            Do
                cptLig& = cptLig& + 1
                A$ = T2(cptLig&, 1)
                If Left(A$, 2) = "ÿþ" Then A$ = Mid(A$, 3)
                Print #i&, A$
            Loop While cptLig& < NbLig

Cordialement.

PMO
Patrick Morange

Couper un fichier txt en plusieurs fichiers [XL-2003]

Macros et VBA Excel

Discussions similaires

Partager

Partager