Discussion :

[meumeu73.1]

Bonjour,

Je cherche un script vba qui me permettrai de faire :

Ouvrir les fichier txt qui commencent par "FICHIER" (exemple)
supprimer les lignes qui ne contiennent pas la chaîne de caractères *******
enregistrer le ou les fichiers au format txt sous un autre nom

Y a t il un ou plusieurs tutos sur ce sujet ou quelqu'un a déjà eu ce genre de script entre les mains, par avance merci pour votre aide.

[kiki29]

Salut, à lire : Manipulation des fichiers en VBA

Au final, de façon bestiale, qqch comme ceci
Affecter un bouton à SelDossier

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
Private Declare Function SHCreateDirectoryEx Lib "Shell32.dll" Alias "SHCreateDirectoryExA" _
                                             (ByVal hwnd As Long, ByVal pszPath As String, ByVal lngsec As Long) As Long
 
Option Explicit
 
Private Function CreationDossier(sDossier) As Long
Dim Rep As Long
    Rep = SHCreateDirectoryEx(0&, sDossier, 0&)
End Function
 
Private Sub Lire(sDossier As String)
Dim sFichierIn As String, sFichierOut As String
Dim sChaine As String
Dim NumFichier1 As Integer, NumFichier2 As Integer
Dim sCheminIn As String, sCheminOut As String, sExt As String
Dim sDossierOut As String
 
    Close
 
    sDossierOut = ThisWorkbook.Path & "\" & "Filtrés"
    CreationDossier sDossierOut
 
    sFichierIn = Dir$(sDossier & "\*.*")
    Do While Len(sFichierIn) > 0
        sExt = Right$(sFichierIn, Len(sFichierIn) - InStrRev(sFichierIn, "."))
        sFichierOut = sFichierIn
        If UCase$(sExt) = "TXT" Then
            sCheminIn = sDossier & "\" & sFichierIn
            sCheminOut = sDossierOut & "\" & sFichierOut
            NumFichier1 = FreeFile
            Open sCheminIn For Input As #NumFichier1
                NumFichier2 = FreeFile
                Open sCheminOut For Output As #NumFichier2
                    Do While Not EOF(NumFichier1)
                        Line Input #NumFichier1, sChaine
                        If InStr(sChaine, "*******") = 0 Then
                            Print #NumFichier2, sChaine
                        End If
                    Loop
                Close #NumFichier2
            Close #NumFichier1
        End If
        sFichierIn = Dir$()
    Loop
End Sub
 
Sub SelDossier()
Dim sChemin As String
    sChemin = ThisWorkbook.Path
 
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = sChemin & "\"
        .Title = "Sélectionner le Dossier Racine"
        .AllowMultiSelect = False
        .ButtonName = "Sélection Dossier"
        .Show
        If .SelectedItems.Count > 0 Then
            DoEvents
            Lire .SelectedItems(1)
        End If
    End With
End Sub

[Theze]

Bonjour,

Adapte le chemin et le mot cherché dans la proc "Test" et teste en la lançant :

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
 
Sub Test()
 
ModifFichier "F:\Dossier1\", "*******"
 
End Sub
 
Function RecupFichiers(Chemin As String, _
                       Racine As String) As String()
 
    Dim TableauFichiers() As String
    Dim Fichier As String
    Dim I As Integer
 
    'boucle dans le dossier jusqu'à
    'la fin des fichiers et rempli le tableau
    Fichier = Dir(Chemin)
 
    Do While (Len(Fichier) > 0)
 
        If UCase(Left(Fichier, 7)) = Racine Then
 
            I = I + 1
            ReDim Preserve TableauFichiers(1 To I)
            TableauFichiers(I) = Chemin & Fichier
            Fichier = Dir()
 
        End If
 
    Loop
 
    RecupFichiers = TableauFichiers()
 
End Function
 
 
Sub ModifFichier(Chemin As String, _
                 MotCherche As String)
 
    Dim TblFichiers() As String
    Dim Tbl() As String
    Dim FichierFinal As String
    Dim Ligne As String
    Dim I As Long
    Dim J As Long
 
    'récupère seulement les fichiers commençant par "FICHIER"
    TblFichiers = RecupFichiers(Chemin, "FICHIER")
 
    'parcour le tableau de fichiers
    For J = 1 To UBound(TblFichiers)
 
        'ouvre en lecture le fichier texte
        Open TblFichiers(J) For Input As #1
 
            Do While Not EOF(1)
 
                'lecture ligne par ligne
                Line Input #1, Ligne
 
                'ne récupère que les lignes contenant le mot cherché
                If InStr(Ligne, MotCherche) <> 0 Then
 
                    I = I + 1
                    ReDim Preserve Tbl(1 To I)
                    Tbl(I) = Ligne
 
                End If
 
            Loop
 
        'ferme
        Close #1
 
        'ouvre le fichier ou le crée si il n'existe pas en gardant le nom du fichier
        'mais en ajoutant le mot "Modifié"
        FichierFinal = Left(TblFichiers(J), Len(TblFichiers(J)) - 4) & "Modifié.txt"
 
        Open FichierFinal For Output As #1
 
            'inscrit les lignes récupérées précédemment
            For I = 1 To UBound(Tbl)
 
                Print #1, Tbl(I)
 
            Next I
 
        Close #1
 
        Erase Tbl
        I = 0
 
    Next J
 
End Sub

Hervé.

[mercatog]

Une autre proposition (à adapter)

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
Sub Main()
Dim Chemin As String, Fichier As String
 
Chemin = "C:\Users\user\Desktop\"                  'A adapter
Fichier = Dir(Chemin & "FICHIER*.txt")
Do While Fichier <> ""
    Call Orgnaiser(Chemin, Fichier, "*******")
    Fichier = Dir()
Loop
MsgBox "Traitement terminé"
End Sub
 
Private Sub Orgnaiser(ByVal Rep As String, ByVal Fich As String, ByVal Txt As String)
Dim Str As String, Res As String
Dim N As Integer
 
N = FreeFile
Open Rep & Fich For Input As N
While Not EOF(N)
    Line Input #N, Str
    If InStr(Str, Txt) > 0 Then Res = IIf(Res = "", Str, Res & vbCrLf & Str)
Wend
Close #N
 
Fich = Rep & Replace(UCase(Fich), "FICHIER", "FICHIER_MODIFIE")
Open Fich For Output As N
Print #N, Res
Close #N
End Sub

[meumeu73.1]

Merci à tous pour votre aide