Macro pour traitement de fichiers Excel

fafardel · 29 Novembre 2011

Bonjour à tous et merci pour votre travail.

D'habitude graçce au forum, j'arrive à trouver toutes mes réponses et/ou à les adapter pour mes besoins 😛

j'ai besoin de vous pour la création d'une macro pour traiter des fichiers txt
Voici le descriptif du boulot que doit effectuer la Macro.

1 : Lister tous les fichiers TXT dans les sous-répertoires d'un dossier et m'inscrire dans une cellule le nom du fichier, le chemin d'accès et le nombre de lignes de ce fichier commençant par XM
==> Là, je bute vraiment sur cette partie.

2 : Ensuite importés tous les fichiers trouvés avec un formatage en séparateur |
==> Là j'ai trouvé comment importés un fichier TXT avec ce format mais je bloque quand il y a plusieurs fichiers TXT à importer.

3 : Ensuite je fais des transfromations sur ce fichier et là j'ai réussi tout ce que je voulai faire donc c'est nickel

4 : Et enfin, je voudrai ensuite enregistrer ce fichier avec le nom du répertoire ou ce fichier se trouvait avec un format d'enregistrement TXT avec séparateur |
du type XXXXX_final.txt

Merci beaucoup de votre aide

Fabien

JNP · 2 Décembre 2011

Re : Macro pour traitement de fichiers Excel

Re 🙂,
Hum... 😛...

Code:

Chemin = ThisWorkbook.Path & "\"

Bye 😎

fafardel · 7 Décembre 2011

Re : Macro pour traitement de fichiers Excel

Bonjour le forum et Merci JNP pour toute l'aide que tu m'apportes.
Je bloque encore sur un souci
Je mets ma macro compléte celle pourra servir à quelqu'un peut - être

Code:

Option Explicit
 Dim I As Long
 Sub Traitement()
 
 'Compte les lignes et les affiche dans le classeur
 Call Comptage
 
 ' Ouvre les fichiers txt
 Call Ouvrir
 
 ' Enregistre les fichiers traités
 
 Call Enregistrement_final
 
 End Sub
 Sub Comptage()
 Dim Chemin As String, Dossier As Object, SousDossier As Object, Fichier As Object
 Dim Valeur As String ' Stocke la valeur à rechercher
 Dim cellule As Range ' Stocke la cellule (objet) trouvée
 
 ' Demande la valeur à rechercher
 Valeur = InputBox("Entrez le chemin du dossier à traiter", _
 "Dossier")
 
 Chemin = Valeur & "\"
 I = 1
 Application.ScreenUpdating = False
 Set Dossier = CreateObject("Scripting.FileSystemObject").GetFolder(Valeur & "\")
 For Each Fichier In Dossier.Files
 'If Left(Fichier.Name, 8) = "TRANSFER" Then
 Cells(I, 1) = Fichier.Name
 Cells(I, 2) = Fichier.Path
 If Right(Fichier.Name, 4) = ".txt" Then Cells(I, 3) = NbreLigne(Fichier.Path)
 I = I + 1
 'End If
 Next
 ListeFichier (Chemin)
 Application.ScreenUpdating = True
 
 End Sub
 
 Function ListeFichier(Chemin As String) As String
 Dim Dossier As Object, SousDossier As Object, Fichier As Object
 Set Dossier = CreateObject("Scripting.FileSystemObject").GetFolder(Chemin)
 For Each SousDossier In Dossier.SubFolders
 ListeFichier (Chemin & SousDossier.Name & "\")
 For Each Fichier In SousDossier.Files
 'If Left(Fichier.Name, 2) = "XM" Then
 Cells(I, 1) = Fichier.Name
 Cells(I, 2) = Fichier.Path
 If Right(Fichier.Name, 4) = ".txt" Then Cells(I, 3) = NbreLigne(Fichier.Path)
 I = I + 1
 'End If
 Next
 Next
 End Function
 
 Function NbreLigne(Chemin As String) As Integer
 Dim MyString As String
 Open Chemin For Input As #1
 Do While Not EOF(1)
     Input #1, MyString
     If Left(MyString, 2) = "XM" Then NbreLigne = NbreLigne + 1
 Loop
 Close #1
 End Function
 
 Sub Enregistrement_final()
 'Enregistrement du fichier en TXT
 Dim Plage As Range
 Dim StrTemp As String, NomFichier As String
 Dim I As Integer, J As Integer
 Dim Chemin As String, Dossier As Object, SousDossier As Object, Fichier As Object
 Dim Valeur As String ' Stocke la valeur à rechercher
 Dim cellule As Range ' Stocke la cellule (objet) trouvée
 
 Valeur = InputBox("Entrez le chemin du dossier à traiter", _
 "Dossier")
 Chemin = Valeur & "\"
 
 NomFichier = Application.GetSaveAsFilename(Valeur & "\transfer_ok", "Text Files (*.txt), *.txt")
 Set Plage = ActiveSheet.UsedRange
 Open NomFichier For Output As #1
 For I = 1 To Plage.Rows.Count
     StrTemp = ""
     For J = 1 To Plage.Columns.Count
         StrTemp = StrTemp & CStr(Cells(I, J).Text) & Chr(124)
     Next J
     Print #1, Left(StrTemp, Len(StrTemp) - 1)
 Next I
 Close #1
 End Sub

Sub Ouvrir()
'
' Ouvrir Macro

' Demande la valeur à rechercher

 Dim Chemin As String, Dossier As Object, SousDossier As Object, Fichier As Object
 Dim Valeur As String ' Stocke la valeur à rechercher
 Dim cellule As Range ' Stocke la cellule (objet) trouvée
'
    Range("A1").Select
    Valeur = InputBox("Entrez le chemin du dossier à traiter", _
 "Dossier")
 Chemin = Valeur & "\"
    ChDir Chemin 'ThisWorkbook.Path
    Workbooks.OpenText Filename:=Chemin & "\transfer.txt", Origin:=xlMSDOS, _
        StartRow:=1, DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _
        ConsecutiveDelimiter:=False, Tab:=False, Semicolon:=False, Comma:=False _
        , Space:=False, Other:=True, OtherChar:="|", FieldInfo:=Array(Array(1, 2 _
        ), Array(2, 2), Array(3, 2), Array(4, 2), Array(5, 2), Array(6, 2), Array(7, 2), Array(8, 2), _
        Array(9, 2), Array(10, 2), Array(11, 2), Array(12, 2), Array(13, 2), Array(14, 2), Array(15 _
        , 2), Array(16, 2), Array(17, 2), Array(18, 2), Array(19, 2), Array(20, 2), Array(21, 2), _
        Array(22, 2), Array(23, 2), Array(24, 2), Array(25, 2), Array(26, 2), Array(27, 2), Array( _
        28, 2), Array(29, 2), Array(30, 2), Array(31, 2), Array(32, 2), Array(33, 2), Array(34, 2), _
        Array(35, 2), Array(36, 2), Array(37, 2), Array(38, 2), Array(39, 2), Array(40, 2), Array( _
        41, 2), Array(42, 2), Array(43, 2), Array(44, 2), Array(45, 2), Array(46, 2), Array(47, 2)) _
        , TrailingMinusNumbers:=True
    ActiveWindow.SmallScroll ToRight:=8
    Range("A1").Select
    
'Insertion de deux colonnes
    Columns("A:A").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    
 '   Séparation de la colonne A1 pour tri par date
 
     Columns("C:C").Select
    Selection.TextToColumns Destination:=Range("A1"), DataType:=xlFixedWidth, _
        OtherChar:="|", FieldInfo:=Array(Array(0, 2), Array(2, 2)), _
        TrailingMinusNumbers:=True
    Columns("C:C").Select
    Selection.Delete Shift:=xlToLeft
    
  ' Copier/Coller des valeurs et supprimer colonne B et C
 Columns("A:A").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
   ActiveCell.FormulaR1C1 = "=CONCATENATE(C[1],C[2])"
  '  Selection.FillDown
    Range("A1").AutoFill Range("A1:A" & Range("B65536").End(xlUp).Row)
    Columns("B:C").Select
    Columns("A:A").Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Columns("B:C").Select
    Application.CutCopyMode = False
    Selection.Delete Shift:=xlToLeft
' End Sub
Const NomFeuille = "transfer"
Const colcritere = "A"
Const PremLig = 1
Dim TabMotsCles
Dim s As String
Dim Lig As Long, DerLig As Long, NumMot As Long, NbMots As Long
Dim trouve As Boolean
  ' initalisations
  TabMotsCles = Array("59M", "59", "13", "13", "JM", "XJ", "XR")
  NbMots = UBound(TabMotsCles, 1)
  Application.ScreenUpdating = False
  With Sheets(NomFeuille)
    ' dernière ligne
    DerLig = .Range(colcritere & 65536).End(xlUp).Row
    ' traitement de la colonne colcritere
    For Lig = DerLig To PremLig Step -1
      ' met en majuscule la cellule
      s = UCase(.Range(colcritere & Lig))
      trouve = False
      ' recherche d'un mot cle dans s
      For NumMot = 1 To NbMots
        If InStr(1, s, TabMotsCles(NumMot)) > 0 Then
          trouve = True
          Exit For
        End If
      Next NumMot
      ' si trouve mot cle supprimer la ligne lig
      If trouve Then
        .Range(colcritere & Lig).EntireRow.Delete
      End If
    Next Lig
  End With
  Application.ScreenUpdating = True
'
' Appelle la Macro de suppression des lignes vides
' Sub SupprimeRow1()
Dim DerLgn As Integer ' défini la variable voir Integer
 Dim Lgn As Integer 'défini la variable
 Application.ScreenUpdating = False ' annule le défilement à l'écran
 With ActiveSheet 'pour la feuille active ou mettre With Sheets("nom de la feuille")
 DerLgn = .Range("A65536").End(xlUp).Row 'Renvoi la dernière ligne utilisée
 'de la colonne A si A est la colonne ou tu peux déterminer la plus Grande Valeur de ligne à traiter
 End With
 For Lgn = DerLgn To 2 Step -1 'on part du bas
 If Cells(Lgn, 1).Value = "" Then ' si la cellule est vide
 Cells(Lgn, 1).EntireRow.Select ' la ligne est selectionnée
 Selection.EntireRow.Delete Shift:=xlUp 'La ligne entière est supprimée par le Haut
 End If
 Next
 Range("A1").Select
 Application.ScreenUpdating = True 'réactive le défilement
 
' Supprimer les lignes vides

 Call Enregistrement_final

End Sub

- Je voudrai maintenant que cette macro scanne tous les sous-répertoires du dossier que je lui indique afin de copier le contenu de chaque fichier TXT dans la feuille excel, l'un à la suite de l'autre
Ou en variante qu'elle concaténe les fichiers txt en un et qu'ensuite elle importe ce fichier final dans le classeur
- La macro actuellement efface toutes les lignes qui ne contiennent pas certains mots clés, je voudrai modifier cela afin qu'elle ne conserve que les lignes XM, mais pas moyen d'y arriver.

Merci de votre aide

JNP · 7 Décembre 2011

Re : Macro pour traitement de fichiers Excel

Re 🙂,
Merci quand tu mets du code d'utiliser le # en version avancé pour mettre ton code entre balises, par ce que là, c'est illisible 😡...
Pour sélectionner le dossier, utilises plutôt

Code:

Sub Test()
Dim fd As FileDialog
Set fd = Application.FileDialog(msoFileDialogFolderPicker)
Dim vrtSelectedItem As Variant
With fd
    If .Show = -1 Then
        MsgBox "Le chemin du dossier est : " & .SelectedItems(1)
    Else
    End If
End With
Set fd = Nothing
End Sub

ça t'évitera bien des soucis 🙄...
Pour l'import, comme je te l'ai dit, utilises

Code:

Dim MyString As String, DerLigne As Integer
DerLigne = 1
Set Dossier = CreateObject("Scripting.FileSystemObject").GetFolder(Valeur & "\")
For Each Fichier In Dossier.Files
    Cells(I, 1) = Fichier.Name
    Cells(I, 2) = Fichier.Path
    If Right(Fichier.Name, 4) = ".txt" Then
        Cells(I, 3) = NbreLigne(Fichier.Path)
        Open Fichier.Path For Input As #1
        Do While Not EOF(1)
            Input #1, MyString
            If Left(MyString, 2) = "XM" Then
                Sheets("Récap").Cells(DerLigne, 1) = MyString
                DerLigne = DerLigne + 1
            End If
        Loop
        Close #1
        I = I + 1
    End If
Next

en modifiant le nom de ta feuille, j'ai mis Récap au hasard 😛...
N'oublie pas de faire les mêmes modifs pour les sous dossier (dans la fonction) en lui envoyant aussi la valeur de DerLigne 😉...
Enfin, si ta ligne a besoin d'être reformatée, il faudrait que je sache à quoi elle ressemble pour pouvoir t'aider 🙄...
Bonne suite 😎

fafardel · 7 Décembre 2011

Re : Macro pour traitement de fichiers Excel

JNP
Encore merci de ton aide

Mais cela n'importe pas les fichiers qui se trouvent dasn les sous-répertoires dans mon classeur Excel

Fabien

JNP · 7 Décembre 2011

Re : Macro pour traitement de fichiers Excel

Re 🙂,

JNP à dit:
N'oublie pas de faire les mêmes modifs pour les sous dossier (dans la fonction) en lui envoyant aussi la valeur de DerLigne 😉...

fafardel à dit:
Mais cela n'importe pas les fichiers qui se trouvent dasn les sous-répertoires dans mon classeur Excel

Hum... Que dire 😱...

fafardel · 7 Décembre 2011

Re : Macro pour traitement de fichiers Excel

Ouais Ouais je sais j'ai parlé trop vite.
Donc cela importe bien les fichiers dans mon classeur excel
Tu as raison je m'incline 😉
Oui mais, je sais ils sont ch..... ces débutants, cela ne me l'importe pas avec un formatage car mes fichiers proviennent d'un import d'un logiciel de transfert
Actuellement quand j'ouvre mes fichiers texte je l'ouvre avec cette commande
Et là je n'arrive pas à l'adapter pour l'insérer dans ta commande :

Code:

ChDir Chemin 'ThisWorkbook.Path
    Workbooks.OpenText Filename:=Chemin & "\transfer.txt", Origin:=xlMSDOS, _
        StartRow:=1, DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _
        ConsecutiveDelimiter:=False, Tab:=False, Semicolon:=False, Comma:=False _
        , Space:=False, Other:=True, OtherChar:="|", FieldInfo:=Array(Array(1, 2 _
        ), Array(2, 2), Array(3, 2), Array(4, 2), Array(5, 2), Array(6, 2), Array(7, 2), Array(8, 2), _
        Array(9, 2), Array(10, 2), Array(11, 2), Array(12, 2), Array(13, 2), Array(14, 2), Array(15 _
        , 2), Array(16, 2), Array(17, 2), Array(18, 2), Array(19, 2), Array(20, 2), Array(21, 2), _
        Array(22, 2), Array(23, 2), Array(24, 2), Array(25, 2), Array(26, 2), Array(27, 2), Array( _
        28, 2), Array(29, 2), Array(30, 2), Array(31, 2), Array(32, 2), Array(33, 2), Array(34, 2), _
        Array(35, 2), Array(36, 2), Array(37, 2), Array(38, 2), Array(39, 2), Array(40, 2), Array( _
        41, 2), Array(42, 2), Array(43, 2), Array(44, 2), Array(45, 2), Array(46, 2), Array(47, 2)) _
        , TrailingMinusNumbers:=True

Merci de ton aide
et de ta patience

Fabien

JNP · 7 Décembre 2011

Re : Macro pour traitement de fichiers Excel

Re 🙂,

fafardel à dit:
Ouais Ouais je sais j'ai parlé trop vite.
Donc cela importe bien les fichiers dans mon classeur excel
Tu as raison je m'incline 😉
Oui mais, je sais ils sont ch..... ces débutants, cela ne me l'importe pas avec un formatage car mes fichiers proviennent d'un import d'un logiciel de transfert
Actuellement quand j'ouvre mes fichiers texte je l'ouvre avec cette commande
Et là je n'arrive pas à l'adapter pour l'insérer dans ta commande :en

JNP à dit:
Enfin, si ta ligne a besoin d'être reformatée, il faudrait que je sache à quoi elle ressemble pour pouvoir t'aider 🙄...

Hum...................!!!! Bis 😱

fafardel · 8 Décembre 2011

Re : Macro pour traitement de fichiers Excel

Bonjour JNP et bonjour le Forum

En fait au moment de l'import le fichier TXt est formaté avec comme séparateur "|".
Donc j'aimerai que lors de l'import de tous les fichiers compris dans tous les sous répertoires cela soit formaté;
Le code actuel qui me permet d'ouvrir ces fichiers TXT avec le bon séparateur est en dessous
Encore Merci

Code:

ChDir Chemin 'ThisWorkbook.Path
     Workbooks.OpenText Filename:=Chemin & "\transfer.txt", Origin:=xlMSDOS, _
         StartRow:=1, DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _
         ConsecutiveDelimiter:=False, Tab:=False, Semicolon:=False, Comma:=False _
         , Space:=False, Other:=True, OtherChar:="|", FieldInfo:=Array(Array(1, 2 _
         ), Array(2, 2), Array(3, 2), Array(4, 2), Array(5, 2), Array(6, 2), Array(7, 2), Array(8, 2), _
         Array(9, 2), Array(10, 2), Array(11, 2), Array(12, 2), Array(13, 2), Array(14, 2), Array(15 _
         , 2), Array(16, 2), Array(17, 2), Array(18, 2), Array(19, 2), Array(20, 2), Array(21, 2), _
         Array(22, 2), Array(23, 2), Array(24, 2), Array(25, 2), Array(26, 2), Array(27, 2), Array( _
         28, 2), Array(29, 2), Array(30, 2), Array(31, 2), Array(32, 2), Array(33, 2), Array(34, 2), _
         Array(35, 2), Array(36, 2), Array(37, 2), Array(38, 2), Array(39, 2), Array(40, 2), Array( _
         41, 2), Array(42, 2), Array(43, 2), Array(44, 2), Array(45, 2), Array(46, 2), Array(47, 2)) _
         , TrailingMinusNumbers:=True

Fabien

JNP · 8 Décembre 2011

Re : Macro pour traitement de fichiers Excel

Re 🙂,

fafardel à dit:
En fait au moment de l'import le fichier TXt est formaté avec comme séparateur "|".
Donc j'aimerai que lors de l'import de tous les fichiers compris dans tous les sous répertoires cela soit formaté;
Le code actuel qui me permet d'ouvrir ces fichiers TXT avec le bon séparateur est en dessous

T'y tiens à ton import 😡...
Personnellement, je n'en veux pas, ne serait-ce parce que c'est stupide d'importer 10000 lignes si tu n'en utilises que 50 🙄...
Bon, à force de travailler par petits bouts, différentes erreurs s'étaient glissées, voici le code corrigé, complet, ET SANS IMPORT 😛...

Code:

Option Explicit
Dim I As Long, DerLigne As Integer
Sub Test()
Dim Chemin As String, Dossier As Object, SousDossier As Object, Fichier As Object
Dim MyString As String, J As Integer
Dim fd As FileDialog
Set fd = Application.FileDialog(msoFileDialogFolderPicker)
Dim vrtSelectedItem As Variant
With fd
    If .Show = -1 Then
        Chemin = .SelectedItems(1)
    Else
    End If
End With
Set fd = Nothing
With Sheets("Feuil1")
    .Cells.Clear
    I = 1
    Application.ScreenUpdating = False
    Sheets("Récap").Cells.Clear
    DerLigne = 1
    Set Dossier = CreateObject("Scripting.FileSystemObject").GetFolder(Chemin & "\")
    For Each Fichier In Dossier.Files
        If Right(Fichier.Name, 4) = ".txt" Then
            .Cells(I, 1) = Fichier.Name
            .Cells(I, 2) = Fichier.Path
            .Cells(I, 3) = NbreLigne(Fichier.Path)
            Open Fichier.Path For Input As #1
            Do While Not EOF(1)
                Input #1, MyString
                If Left(MyString, 2) = "XM" Then
                    For J = LBound(Split(MyString, "|")) To UBound(Split(MyString, "|"))
                        Sheets("Récap").Cells(DerLigne, J + 1) = Split(MyString, "|")(J)
                    Next J
                    DerLigne = DerLigne + 1
                End If
            Loop
            Close #1
            I = I + 1
        End If
    Next
    ListeFichier (Chemin & "\")
    Application.ScreenUpdating = True
End With
End Sub
Function ListeFichier(Chemin As String) As String
Dim Dossier As Object, SousDossier As Object, Fichier As Object
Dim MyString As String, J As Integer
With Sheets("Feuil1")
    Set Dossier = CreateObject("Scripting.FileSystemObject").GetFolder(Chemin)
    For Each SousDossier In Dossier.SubFolders
        ListeFichier (Chemin & SousDossier.Name & "\")
        For Each Fichier In SousDossier.Files
            If Right(Fichier.Name, 4) = ".txt" Then
                .Cells(I, 1) = Fichier.Name
                .Cells(I, 2) = Fichier.Path
                .Cells(I, 3) = NbreLigne(Fichier.Path)
                Open Fichier.Path For Input As #1
                Do While Not EOF(1)
                    Input #1, MyString
                    If Left(MyString, 2) = "XM" Then
                        For J = LBound(Split(MyString, "|")) To UBound(Split(MyString, "|"))
                            Sheets("Récap").Cells(DerLigne, J + 1) = Split(MyString, "|")(J)
                        Next J
                        DerLigne = DerLigne + 1
                    End If
                Loop
                Close #1
                I = I + 1
            End If
        Next
    Next
End With
End Function
Function NbreLigne(Chemin As String) As Integer
Dim MyString As String
Open Chemin For Input As #1
Do While Not EOF(1)
    Input #1, MyString
    If Left(MyString, 2) = "XM" Then NbreLigne = NbreLigne + 1
Loop
Close #1
End Function

Bonne suite 😎

fafardel · 9 Décembre 2011

Re : Macro pour traitement de fichiers Excel

Bonjour JNP, Bonjour le Forum,

Quand je lance la macro, je sélectionne le dossier et j'ai un message d'erreur qui me dis
L'indice n'appartient pas à la sélection
==> désolé j'ai encore parlé trop vite, la feuille récap n'existait pas sur mon classeur et il fallait que la sélectionne, je vais l'inclure dans la procédure pour éviter les erreurs de manipulation

Merci
Fabien

Effectuez une recherche sur Excel Downloads...

Macro pour traitement de fichiers Excel

fafardel

XLDnaute Nouveau

JNP

XLDnaute Barbatruc

fafardel

XLDnaute Nouveau

JNP

XLDnaute Barbatruc

fafardel

XLDnaute Nouveau

JNP

XLDnaute Barbatruc

fafardel

XLDnaute Nouveau

JNP

XLDnaute Barbatruc

fafardel

XLDnaute Nouveau

JNP

XLDnaute Barbatruc

fafardel

XLDnaute Nouveau

Discussions similaires

Nous accordons de l'importance à votre vie privée