Discussion :

[capi81]

Salut le forum

DAns le lien ci-dessus, j'avais posé un problème de traitement automatisé de fichier texte.
J'ai eu une réponse satisfaisante mais aujourd'hui le format des fichiers texte a changé (avant c'était en francais mais aujourd'hui les données sont en anglais.
Je vous joins les deux modèles de fichiers texte pour appréciation.
Ancien fichier texte qui fonctionne toujours bien http://www.cjoint.com/c/EFerk0SIyiN
Nouveau fichier texte (après changement de logiciel de notre structure) http://www.cjoint.com/c/EFermVoAoNN
Il y'a au moins 30 fichiers au format texte (version anglaise) dans mon dossier. Le code me permettait de faciliter le traitement mais aujourd'hui il ne fonctionne plus. Il n'arrive pas à importer les fichiers et les convertir comme souhaité. J'ai bau essayé par tous les moyens mais je trouve pas de solution.
Je viens vers vous pour l'apprécier.

http://www.developpez.net/forums/d14...pte-situation/

NB: je salue encore au passage ceux qui avaient contribué à sa réalisation

[Invité]

Bonjour,
je t'invite a utiliser l'enregistreure de macro pour ouvire ton fichier en précisant séparation par tabulation.

Je suis sur mon téléphone je ne peux pas fair mieux!

[capi81]

Bonsoir rdurupt

J'ai essayé déjà par l'enregistreur mais le problème est qu'il ne permet pas de faire des boucles.
Voici ce que j'avais déjà essayé avant le post:

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
Sub traitement()
'
' traitement Macro
'
 
'
    With ActiveSheet.QueryTables.Add(Connection:= _
        "TEXT;C:\Users\BF0171\Desktop\BILAN31052015\ebilncgag01004.rep", Destination _
        :=Range("$A$1"))
        .Name = "ebilncgag01004"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .TextFilePromptOnRefresh = False
        .TextFilePlatform = 850
        .TextFileStartRow = 1
        .TextFileParseType = xlFixedWidth
        .TextFileTextQualifier = xlTextQualifierDoubleQuote
        .TextFileConsecutiveDelimiter = False
        .TextFileTabDelimiter = True
        .TextFileSemicolonDelimiter = False
        .TextFileCommaDelimiter = False
        .TextFileSpaceDelimiter = False
        .TextFileColumnDataTypes = Array(1, 1, 2, 1, 1, 1, 1, 1, 1, 1, 1)
        .TextFileFixedColumnWidths = Array(6, 8, 6, 16, 20, 20, 20, 8, 9, 9)
        .TextFileTrailingMinusNumbers = True
        .Refresh BackgroundQuery:=False
    End With
    Range("A:B,E:F").Select
    Range("E1").Activate
    ActiveWindow.SmallScroll ToRight:=2
    Range("A:B,E:F,I:K").Select
    Range("I1").Activate
    Selection.Delete Shift:=xlToLeft
    Range("A16").Select
    ActiveWindow.SmallScroll Down:=-9
    Rows("1:3").Select
    Selection.ClearContents
    Columns("A:A").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Rows("1:3").Select
    Selection.Delete Shift:=xlUp
    Range("A1").Select
    ActiveCell.FormulaR1C1 = "Agence"
    Range("B1").Select
    ActiveCell.FormulaR1C1 = "RC"
    Range("C1").Select
    ActiveCell.FormulaR1C1 = "INTITULE"
    Range("D1").Select
    ActiveCell.FormulaR1C1 = "MONTANT"
    Range("E1").Select
    ActiveCell.FormulaR1C1 = "NBRE"
    Range("A2").Select
    ActiveWindow.SmallScroll Down:=-9
End Sub

Avec ca lorsque je dois passer au fichier texte suivant je dois faire des modifications manuellement.
Ce que je souhaite éviter.
Je suis appeler à réaliser le traitement chaque semaine voila pourquoi je cherche quelque chose de solide.
A bientôt

[Invité]

Non tu ouvre le fichier comme si c'était un xls mais tu précise csv avec tabulation.

[capi81]

J'essai de faire ce vous proposez mais j'y arrive. Pouvez-vous m'indiquer la procedure a suivre. J'utilise excel 2010

[tamtam64]

Salut tu peux nous dire si c'est des chiffres , quel genre de contenu?


tu peux delimiter ce que tu veux en utilisant l'enregistreur de macro , dis nous ton probleme ton erreur et aussi ce que tu veux faire .

Code :

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

1
2
3
4
5
6
7
8
9
10
Sub ImportText(ByVal FileName As String, ByVal PosImport As Range)
    Dim QT As QueryTable
    Set QT = ActiveSheet.QueryTables.Add(Connection:="TEXT;" & FileName, Destination:=PosImport)
    With QT
        .TextFileSemicolonDelimiter = True
        .TextFileTextQualifier = xlTextQualifierDoubleQuote
        .TextFileCommaDelimiter = True
        .Refresh
    End With
End Sub

[capi81]

Salut Tamtam64 et le forum

Merci pour votre intervention.
Voici mon besoin:

Salut le forum

J’ai un fichier texte que je souhaite qu’on m’aide à automatiser son traitement.
En effet, mon dossier contient 32 fichiers texte que je dois retraiter manuellement.
Le traitement est récurrent et c’est toujours le même procédé ; voila pourquoi je souhaite qu’on m’aide à l’automatiser (je passe plus de 7h de temps pour le traitement avec tout le risque d’erreur que cela comporte).

Voici le nom de mes fichiers texte contenus dans dossier « BILAN AGENCES » du bureau: ebilncgag01001.rep, ebilncgag01002.rep, ……. ebilncgag01018.rep, ebilncgag02001.rep, ebilncgag02002.rep, ebilncgag02003.rep, ebilncgag03001.rep, ebilncgag04001.rep, ebilncgag05001.rep, ebilncgag09001.rep, ebilncgag12001.rep, ebilncgag14001.rep, ebilncgag15001.rep, ebilncgag15005.rep, ebilncgag16017.rep, ebilncgag17001.rep, ebilncgag17002.rep

Etape 1 : est-il possible de mettre en place un code qui permettra de convertir chaque fichier texte et de les ranger par feuille(le nom de chaque feuille devant être les chiffres du nom du fichier. Exemple ebilncgag01001.rep aura comme nom de fichier 01001, ebilncgag01002.rep = 01002 etc…).
N.B : lors de la conversion, toutes les colonnes comportant des chiffres devront être converties en format texte.

Etape 2 : les colonnes B, E, F, I, J, K devront être supprimées simultanément

Etape3 : dans la nouvelle colonne B (après suppression de la 1ère colonne B), toutes les cellules vides de même que celles dont le nombre de caractère est inférieur à 6 devront être supprimées

Etape 4 : insérer une nouvelle ligne à partir de la 1ère ligne et mettre respectivement de A1 :E1 les titres suivants : Code Agence, RC, Libellé, Montant et Nbre

Etape 5 : la plage de la colonne A correspondant à la plage non vide de la colonne B devra porter le nom de la feuille. Exemple de la feuille portant le nom 01001 : Si B2 :B20 est non vide, A2 :A20 aura pour contenu 01001.

Etape 6 : remplacer les virgules (,) de même que les .00 des colonnes D et E par du vide.

Etape 7 : insérer une nouvelle feuille qui sera nommée SOURCE.

Etape 8 : sur chaque feuille du classeur, copier toutes les lignes ou il y aura 251125, 251132, 251134, 253110, 253111, 253115, 253116, 253210, 253216 et 253900 dans la colonne B et les coller dans la feuille SOURCE

Je reste à votre disposition pour tout complément d'information

Il faut dire que j'avais eu une aide qui fonctionnait bien mais depuis que nous avons changé de logiciel, lorsque le service informatique nous envois les nouvelles données au format texte, à l'exécution rien ne se produit.
La macro tourne mais n'arrive pas à importer les fichier et procéder au traitement nécessaire.
Je profite vous communiquer les différents code qui fonctionnait avant le passage au nouveau logiciel:

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
Option Explicit
'Source : http://www.vbaexpress.com/kb/getarticle.php?kb_id=284
Function Browseforfolder(Optional OpenAt As Variant) As Variant
     'Function purpose:  To Browser for a user selected folder.
     'If the "OpenAt" path is provided, open the browser at that directory
     'NOTE:  If invalid, it will open at the Desktop level
 
    Dim ShellApp As Object
 
     'Create a file browser window at the default folder
    Set ShellApp = CreateObject("Shell.Application"). _
    Browseforfolder(0, "Choisissez le répertoire contenant les fichiers à importer", 0, OpenAt)
 
     'Set the folder to that selected.  (On error in case cancelled)
    On Error Resume Next
    Browseforfolder = ShellApp.self.Path
    On Error GoTo 0
 
     'Destroy the Shell Application
    Set ShellApp = Nothing
 
     'Check for invalid or non-entries and send to the Invalid error
     'handler if found
     'Valid selections can begin L: (where L is a letter) or
     '\\ (as in \\servername\sharename.  All others are invalid
    Select Case Mid(Browseforfolder, 2, 1)
    Case Is = ":"
        If Left(Browseforfolder, 1) = ":" Then GoTo Invalid
    Case Is = "\"
        If Not Left(Browseforfolder, 1) = "\" Then GoTo Invalid
    Case Else
        GoTo Invalid
    End Select
 
    Exit Function
 
Invalid:
     'If it was determined that the selection was invalid, set to False
    Browseforfolder = False
 
End Function

Code suivant

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
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
Sub Zomaplus() 'By Mr Zomaplus
 
Dim Curcalc As XlCalculation
Dim ws, Ws2 As Worksheet
Dim Chemin As String, Fichier As String
 
Application.ScreenUpdating = False
Curcalc = Application.Calculation
Application.Calculation = xlCalculationManual
 
 
'Définit le répertoire contenant les fichiers
'On Error GoTo std_errhandler
 
If Sheets("Menu").Range("B7").Value = "" Then
    Chemin = Browseforfolder()
    Sheets("Menu").Range("B7") = Chemin
Else
    Chemin = Sheets("Menu").Range("B7").Value
 
End If
 
If Chemin = "" Then Exit Sub
'Boucle sur tous les fichiers rep du répertoire.
Fichier = Dir(Chemin & "\*.rep")
 
If Fichier = "" Then MsgBox "Aucun fichier de type .rep dans le répertoire sélectionné"
 
Do While Len(Fichier) > 0
    'Debug.Print Chemin & Fichier
    Application.StatusBar = "Traitement en cours : " & Fichier
 
    'On vérifie qu'il n'y ait pas de feuille déjà ayant pour nom le même que celui que l'on veut lui donner
    For Each Ws2 In ThisWorkbook.Sheets
        If Ws2.Name = Mid(Fichier, 10, 5) Then
            MsgBox ("Une feuille existe déjà avec pour nom : " & Ws2.Name & vbCrLf & "Merci de bien vouloir la supprimer ou la renommer")
            Exit Sub
        End If
    Next Ws2
 
    Set ws = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
    ws.Name = Mid(Fichier, 10, 5)
    'Contient l'ensemble des opérations à effectuer sur le fichier spécifié
    Call Execution(Chemin & "\" & Fichier, ws)
 
    Fichier = Dir()
Loop
Set ws = Nothing
Set Ws2 = Nothing
 
Sheets("Menu").Select
 
Application.Calculation = Curcalc
Application.ScreenUpdating = True
Application.StatusBar = False
Exit Sub
 
std_errhandler:
MsgBox "Erreur : " & Err.Number & vbCrLf & Err.Description
 
Application.Calculation = Curcalc
Application.ScreenUpdating = True
End Sub
 
Sub Execution(repertoire_source As String, ByVal Cible As Worksheet)
 
Dim I As Long
Dim Max_ligne As Long
Dim last_source_line As Long
 
Dim B, Str As String
Dim Val_possibles(60) As Variant
Dim Match As Boolean
Dim Lignes_a_suppr As Collection
Dim L As Variant
 
Dim source As Worksheet
 
'Import du fichier
Call copie(Cible, repertoire_source)
'Split en colonnes
Call Split(Cible)
 
Set source = Sheets("Source")
'Suppression des colonnes B,E,F,I,J,K
Cible.Columns("k:k").Delete Shift:=xlToLeft
Cible.Columns("j:j").Delete Shift:=xlToLeft
Cible.Columns("i:i").Delete Shift:=xlToLeft
Cible.Columns("f:f").Delete Shift:=xlToLeft
Cible.Columns("e:e").Delete Shift:=xlToLeft
Cible.Columns("b:b").Delete Shift:=xlToLeft
 
'Suppression des lignes pour lesquelles la cellule B est de longueur inférieure à 6
'Les lignes sont d'abord stockées dans une collection, afin de ne pas perturber la boucle
'Puis tous les membres de la collection sont supprimés
Max_ligne = Cible.UsedRange.Rows.Count
Set Lignes_a_suppr = New Collection
 
For I = 1 To Max_ligne
    Str = Cible.Cells(I, 2).Value
    Str = Replace(Str, " ", "")
 
    If Len(Str) < 6 Or Str = "------" Then 'la condition 6 tirets n'est pas dans le cahier des charges mais elle m'a paru évidente
        Lignes_a_suppr.Add Cible.Cells(I, 2).EntireRow
    End If
Next I
For Each L In Lignes_a_suppr
    L.Delete
Next L
 
Set Lignes_a_suppr = Nothing
 
'Insertion d'une ligne
Cible.Rows("1:1").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
 
'Titres des colonnes
Cible.Cells(1, 1).Formula = "Code Agence"
Cible.Cells(1, 2).Formula = "RC"
Cible.Cells(1, 3).Formula = "Libellé"
Cible.Cells(1, 4).Formula = "Montant"
Cible.Cells(1, 5).Formula = "Nbre"
 
'Inscription du nom de la feuille en colonne A si b non vide, ou b rempli de blancs
For I = 2 To Max_ligne
    If Replace(Cible.Cells(I, 2).Value, " ", "") <> "" Then
        Cible.Cells(I, 1).Value = Cible.Name
    End If
Next I
 
 
'Suppression des .00 et des virgules
 
Cible.Range("D:E").Replace What:=".00", Replacement:="", LookAt:=xlPart, _
    SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
    ReplaceFormat:=False
 
Cible.Range("D:E").Replace What:=",", Replacement:="", LookAt:=xlPart, _
    SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
    ReplaceFormat:=False
 
End Sub
 
Sub copie(Feuille_cible As Worksheet, Path_source As String)
'Copie des lignes des fichiers .rep
'Code par Mr Poulpe, légèrement adapté
 
Dim intFic, I As Integer
Dim strLigne As String
 
intFic = FreeFile
Open Path_source For Input As intFic
I = 1
While Not EOF(intFic)
    Line Input #intFic, strLigne
    Feuille_cible.Cells(I, 1) = strLigne
    I = I + 1
Wend
Close intFic
 
End Sub
 
Sub Split(Feuille_cible As Worksheet)
'Ce code utilise la ligne 6 des fichiers REP, qui définit la largeur en nombre de caractères de chaque colonne. Le nombre de tirets consécutifs correspond à la largeur de la colonne
'On compte donc le nombre de tirets consécutifs, puis on stocke le résultat de chaque série de tirets dans une collection
'Ensuite, il suffit de découper la première colonne selon les largeurs de colonnes obtenues pour remettre les valeurs en colonne
Dim Col_sizes As Collection
Dim Cnt As Integer
Dim cell_size As Integer
Dim I, j As Long
Dim Master_cell As Range
Dim Max_lignes As Long
Dim gauche_cellule As Long
Dim str_temp As String
 
Set Col_sizes = New Collection
Set Master_cell = Feuille_cible.Cells(6, 1)
cell_size = Len(Master_cell)
Cnt = 0
For I = 1 To cell_size
    If Mid(Master_cell.Value, I, 1) = "-" Then
        Cnt = Cnt + 1
    Else
        Col_sizes.Add Cnt
        Cnt = 0
    End If
Next I
 
Max_lignes = Feuille_cible.UsedRange.Rows.Count
 
With Feuille_cible
 
    For I = 1 To Max_lignes
        j = 1
        str_temp = .Cells(I, 1).Value
        If str_temp <> "" Then
            gauche_cellule = 1
            For Each c In Col_sizes
                If (gauche_cellule + c) < Len(str_temp) Then
                    .Cells(I, j).NumberFormat = "@"
                    .Cells(I, j) = Mid(str_temp, gauche_cellule, CLng(c))
                    j = j + 1
                    gauche_cellule = gauche_cellule + c + 1
                Else
                    .Cells(I, j).NumberFormat = "@"
                    .Cells(I, j) = Mid(str_temp, gauche_cellule)
 
                    Exit For
                End If
 
            Next c
 
        End If
    Next I
 
End With
 
End Sub

Voici le dernier:

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
Option Explicit
Option Private Module
Public Sub Consolider_feuilles()
Dim ws As Worksheet, wsd As Worksheet, wsc As Worksheet
Dim lastRow As Long, lRow As Long, I As Long
Dim lastCol As Integer
Dim rng As Range
Dim a, p
 
    Application.ScreenUpdating = False
 
    Set wsd = Worksheets("SOURCE")
    Set wsc = Worksheets("CODES")
    With wsd
        .Range("A:E").Clear
        .[A1:E1] = Array("CODE", "RC", "INTITULE", "MONTANT", "NOMBRE")
    End With
 
    lRow = 2
 
    For Each ws In ActiveWorkbook.Worksheets
        If IsNumeric(ws.Name) Then
            lastRow = ws.Cells(Rows.Count, 1).End(xlUp).Row
            lastCol = ws.Cells(1, Columns.Count).End(xlToLeft).Column
            ws.Cells(2, 1).Resize(lastRow, lastCol).Copy
            wsd.Cells(lRow, 1).PasteSpecial xlPasteFormulasAndNumberFormats
            lRow = wsd.Cells(Rows.Count, 1).End(xlUp).Row + 1
        End If
    Next
 
    lastRow = wsc.Cells(Rows.Count, 1).End(xlUp).Row
    a = wsc.Range("A2:A" & lastRow).Value
    lastRow = wsd.Cells(Rows.Count, 2).End(xlUp).Row
    For I = lastRow To 2 Step -1
        p = Application.VLookup(CDbl(wsd.Cells(I, 2)), a, 1, False)
        If IsError(p) Then wsd.Rows(I).Delete
    Next
 
    Set wsc = Nothing: Set wsd = Nothing: Set rng = Nothing
 
End Sub
Public Sub test()
MsgBox VarType(ActiveCell)
End Sub

Je reste à votre disposition plus d'information