Rassembler plusieur fichier txt en un seul.

[julbute]

Bonjour, je vais avoir besoin de votre aide.(Une fois de plus)
J'ai plusieurs fichiers dans le même répertoire au format texte, le nom du fichier correspond à la date.ils sont en fichier joint.
Voici ma problèmatique:
Ils ont tous le même format, mais il n'ont pas tous le même nombre de ligne.
L'entete est toujours la même.Il faudrait pouvoir ouvrir tout les fichiers, les importer sur une feuille excel en utilisant les séparateurs ",".La première ligne ne me sert à rien,elle doit etre eliminé.J'ai besoin de récupere sur chaque ligne le nom du fichier(qui correspond à la date) plus toutes les données de chaque ligne.J'ai besoin de traiter ces informations dans un tableau croisés dynamique.(cela je sais faire...) Ce qui fait que toutes les infos doivent etre sur la même feuille.

Voici mon idée.
- Créer un fichier "Total.xls" avec une feuille nomée "Récap".
- lancer une macro
- Compter le monbre de fichier dans le répertoire.
- créer une boucle avec le nombre de fichier
- ouvrir le premier fichier
- créer une feuille avec le nom du fichier comme nom de feuille.
- importer les données vers ce fichier.
- effacer la première ligne, je n'en a pas besoin.
- compter le nombre de ligne
- copier sur la feuille récap, dans la première colonne le nom de la feuille ( donc la date) et dans les cellules de la ligne le reste des données et ainsi de suite.
- effacer la feuille lorsque toutes les données ont été transféré.
- recommencer jusqu'au dernier fichier.

c'est trés certainement perfectible comme procedure...
J'ai environ 800 fichiers à traiter, ce qui explique mon envie d'automatiser cela...

Merci
Roger

 

[Staple1600]

Re : Rassembler plusieur fichier txt en un seul.

Bonsoir


Une solution à la mode du temps jadis

1) copie ceci dans un fichier texte et enregistre sous compil.bat

copy /A *.pro compil_pro.xls
start compil_pro.xls

2)Dans ce classeur qui vient de s'ouvrir, exécute cette macro

Sub Macro1()
Dim c As Range, r As Range
Columns("A:A").TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, Comma:=True
Cells.Columns.AutoFit
Rows("1:1").Delete Shift:=xlUp
Columns("C:C").Delete Shift:=xlToLeft
Set r = ActiveSheet.UsedRange
For Each c In r
c.Value = Replace(c.Text, Chr(26), "")
Next
End Sub

 

[Hulk]

Re : Rassembler plusieur fichier txt en un seul.

Hello,

Petite paranthèse :

Staple, je n'arrive pas à éditer mes fichiers bat ou cmd, tu as une idée ?




EDIT : C'est bon

Merci.

 

[Staple1600]

Re : Rassembler plusieur fichier txt en un seul.

Bonsoir Hulk



Clic-droit -> Modifier non ?

EDITION: houps j'avais pas vu ton EDIT

EDITION2: je viens de me rendre qu'avec ma solution, tous les fichiers seront dans la même feuille, ce qui n'est pas le but recherché.

 

[Staple1600]

Re : Rassembler plusieur fichier txt en un seul.

Re


Avec ce code de Ron de Bruin, adapté à ta problématique

ca devrait le faire

Tu lances la macro IMPORT_FICHIERS_PRO

Option Explicit

Private Declare Function SetCurrentDirectoryA Lib _
        "kernel32" (ByVal lpPathName As String) As Long

Public Function ChDirNet(szPath As String) As Boolean
[COLOR=Green]'based on Rob Bovey's code[/COLOR]
    Dim lReturn As Long
    lReturn = SetCurrentDirectoryA(szPath)
    ChDirNet = CBool(lReturn <> 0)
End Function

Sub IMPORT_FICHIERS_PRO()
[COLOR=Green]'For Excel 2000 and higher[/COLOR]
    Dim Fnum As Long, f As Worksheet, a As Workbook, NMF
    Dim QTable As QueryTable, SaveDriveDir$, ExistFolder As Boolean

    SaveDriveDir = CurDir

    ExistFolder = ChDirNet(Application.DefaultFilePath)
    If ExistFolder = False Then
        MsgBox "Error changing folder"
        Exit Sub
    End If

    NMF = Application.GetOpenFilename _
    (filefilter:="Fichiers PRO (*.pro), *.pro", MultiSelect:=True)

    If IsArray(NMF) Then
        On Error GoTo CleanUp
        With Application
            .ScreenUpdating = False
            .EnableEvents = False
        End With
        'Add workbook with one sheet
        Set a = Workbooks.Add(xlWorksheet)
        'Loop through the array with txt files
        For Fnum = LBound(NMF) To UBound(NMF)
            'Add a new worksheet for the name of the txt file
            Set f = Worksheets.Add(After:=a.Sheets(a.Sheets.Count))
            On Error Resume Next
            f.Name = Split(NMF(Fnum), "\")(UBound(Split(NMF(Fnum), "\")))
            On Error GoTo 0
            With ActiveSheet.QueryTables.Add(Connection:= _
                        "TEXT;" & NMF(Fnum), Destination:=Range("A1"))
                .TextFilePlatform = xlWindows
                .TextFileStartRow = 2
                .TextFileParseType = xlDelimited
                'Set your Delimiter to true
                .TextFileTabDelimiter = False
                .TextFileSemicolonDelimiter = False
                .TextFileCommaDelimiter = True
                .TextFileSpaceDelimiter = False
                .Refresh BackgroundQuery:=False
            End With
        ActiveSheet.QueryTables(1).Delete
        Next Fnum
        'Delete the first sheet of a
        On Error Resume Next
        Application.DisplayAlerts = False
        a.Worksheets(1).Delete
        Application.DisplayAlerts = True
        On Error GoTo 0
CleanUp:
        ChDirNet SaveDriveDir
        With Application
            .ScreenUpdating = True
            .EnableEvents = True
        End With
    End If
End Sub

 

[julbute]

Re : Rassembler plusieur fichier txt en un seul.

Bonjour, merci pour les infos.
Je vais essayer tout cela,je connaisais deja cela:
copy /A *.pro compil_pro.xls
Mais le problème c'est que je n'ai pas la date et que tout les fichiers sont complilés les un derrière les autres.Et cela ne convient pas pour le trie des infos..
Je regarde le reste, et je reviens vers vous.
Je vais etudier le code de staple...
J'ai un peu de mal à le comprendre de suite.
Merci
Roger

 

[julbute]

Re : Rassembler plusieur fichier txt en un seul.

Parfait...
Tout les fichiers sont importés dans le même classeur.
Mais j'aimerai qu'il soient tous rassemblé sur une même feuille, en retrouvant dans la colonne A le nom de l'onglet(la date), sur chaque ligne.
C'est un peut trop demandé peut etre mais je ne sais pas trop comment faire.
à la suite de la macro,j'ai créé une nouvelle feuille "récap".

Sub IMPORT_FICHIERS_PRO()
'For Excel 2000 and higher
Dim Fnum As Long, f As Worksheet, a As Workbook, NMF
Dim QTable As QueryTable, SaveDriveDir$, ExistFolder As Boolean
Dim nb_onglets As Long ' Roger
Dim plage As Range ' Roger

SaveDriveDir = CurDir

ExistFolder = ChDirNet(Application.DefaultFilePath)
If ExistFolder = False Then
MsgBox "Error changing folder"
Exit Sub
End If

NMF = Application.GetOpenFilename _
(filefilter:="Fichiers PRO (*.pro), *.pro", MultiSelect:=True)

If IsArray(NMF) Then
On Error GoTo CleanUp
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
'Add workbook with one sheet
Set a = Workbooks.Add(xlWorksheet)
'Loop through the array with txt files
For Fnum = LBound(NMF) To UBound(NMF)
'Add a new worksheet for the name of the txt file
Set f = Worksheets.Add(After:=a.Sheets(a.Sheets.Count))
On Error Resume Next
f.Name = Split(NMF(Fnum), "\")(UBound(Split(NMF(Fnum), "\")))
On Error GoTo 0
With ActiveSheet.QueryTables.Add(Connection:= _
"TEXT;" & NMF(Fnum), Destination:=Range("A1"))
.TextFilePlatform = xlWindows
.TextFileStartRow = 2
.TextFileParseType = xlDelimited
'Set your Delimiter to true
.TextFileTabDelimiter = False
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = True
.TextFileSpaceDelimiter = False
.Refresh BackgroundQuery:=False
End With
ActiveSheet.QueryTables(1).Delete
Next Fnum
'Delete the first sheet of a
On Error Resume Next
Application.DisplayAlerts = False
a.Worksheets(1).Delete
Application.DisplayAlerts = True
On Error GoTo 0
CleanUp:
ChDirNet SaveDriveDir
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End If

Sheets.Add.Name = "Récap" 'Roger
nb_onglets = Sheets.Count 'Roger
For n = 1 To nb_onglets 'Roger
ThisWorkbook.Worksheets (n) 'Roger
plage = Range("A1").CurrentRegion 'Roger
ThisWorkbook.Worksheets("recap").Activate 'Roger
Range("A1").End(xlDown).Row = plage 'Roger
Next n 'Roger


End Sub


Mais je n'arrive pas à tous rassembler dessus, il y a des erreurs.
Je ne suis vraiment pas trés fort en vba.Tous les instructions simples cela va .
Mais là cela me dépasse...
Merci de votre aide.
Roger

 

[Staple1600]

Re : Rassembler plusieur fichier txt en un seul.

Bonjour julbute, le fil, le forum


Un autre approche (avec un mix d'une de mes réponses dans un autre fil )

Sub import_pro()
Dim i As Long, a As Workbook, donnees As Range
With Application.FileSearch
    .NewSearch
    .Filename = "*.pro"
    .LookIn = "C:\testoo\"
    .Execute
    For i = 1 To .FoundFiles.Count
                    Workbooks.OpenText .FoundFiles(i), _
                    Origin:=xlWindows, StartRow:=2, DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _
                        ConsecutiveDelimiter:=False, Tab:=False, Semicolon:=False, Comma:=True, Space:=False, Other:=False
                        Set a = ActiveWorkbook
                        Set donnees = a.Sheets(1).[A1].CurrentRegion
                        ThisWorkbook.Sheets("IMPORTATION").[A65536].End(xlUp)(2) = Split(.FoundFiles(i), "\")(UBound(Split(.FoundFiles(i), "\")))
                        donnees.Copy ThisWorkbook.Sheets("IMPORTATION").[A65536].End(xlUp)(2)
                        a.Close False
                        Set a = Nothing
                        Set donnees = Nothing
                        Application.CutCopyMode = False
        Next i
End With
ThisWorkbook.Worksheets("IMPORTATION").Rows(1).Delete
End Sub

 

[julbute]

Re : Rassembler plusieur fichier txt en un seul.

Bonjour à tous
merci Staple1600 de te pencher sur mon cas.
Cela fonctionne mais cela n'enregistre que le nom du fichier et les deux première données entre les virgules.Les reste n'est pas pris en compte.
Ce ne serait pas à cause de cette ligne?

Set donnees = a.Sheets(1).[A1].CurrentRegion

Etant donné que dans mon fichier source la troisième données et toujours vide, donc la cellule dans la colonne "C" est vide.


Merci
Roger

 

[Staple1600]

Re : Rassembler plusieur fichier txt en un seul.

Bonsoir


J'ai testé avec les fichiers *.pro qui étaient dans ta pièce jointe.
Ces fichiers contenaient deux lignes.

Donc cela fonctionne avec ces fichiers de test

Essaie ainsi

Set donnees = a.Sheets(1).UsedRange

 

[julbute]

Re : Rassembler plusieur fichier txt en un seul.

Parfait, cela fonctionne trés bien.Je n'ai plus qu'a formater tout cela pour l'annalyser.
Merci beaucoup.
quelle est la différence entre :

Set donnees = a.Sheets(1).[A1].CurrentRegion

et

Set donnees = a.Sheets(1).UsedRange

 

[Staple1600]

Re : Rassembler plusieur fichier txt en un seul.

Bonsoir


Issue de l'aide en ligne de VBA

CurrentRegion, propriété
Renvoie un objet Range qui représente la zone en cours. Celle-ci est une plage limitée par toute combinaison de lignes et de colonnes vides. En lecture seule.
Remarque
Cette propriété est utile pour de nombreuses opérations qui étendent automatiquement la sélection de façon à y inclure toute la zone en cours, à l'exemple de la méthode AutoFormat.
Cette propriété ne peut pas être utilisée dans une feuille de calcul protégée.

je te laisse chercher pour UsedRange
(ALT+F11 -> F1)

 

[julbute]

Re : Rassembler plusieur fichier txt en un seul.

Ok c'était un peu facile de poser des questions sans faire de demarche de recherche.
Je te l'accorde... ;-)
Merci encore.
Roger

 

[julbute]

Re : Rassembler plusieur fichier txt en un seul.

Bonjour staple1600,
j'ai ajouté tout "mon traitement" à ta macro.
Elle est surement loin d'être parfaite.
Peux tu me donner ton avis et me corriger, si tu veux bien?
Car il y a trés certainement plus simple à faire.
Merci.
Roger

 

[Staple1600]

Re : Rassembler plusieur fichier txt en un seul.

Bonsoir


Une première modif (pour la mise en forme des dates)

Sub import_pro2()
Dim i As Long, a As Workbook, donnees As Range
Application.ScreenUpdating = False
With Application.FileSearch
    .NewSearch
    .Filename = "*.pro"
    .LookIn = ThisWorkbook.Path
    .Execute
    For i = 1 To .FoundFiles.Count
        Workbooks.OpenText .FoundFiles(i), _
        Origin:=xlWindows, StartRow:=2, DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, Semicolon:=False, Comma:=True, Space:=False, Other:=False
        Set a = ActiveWorkbook
        Set donnees = a.Sheets(1).[A1].UsedRange
        ThisWorkbook.Sheets("IMPORTATION").[A65536].End(xlUp)(2) = Split(.FoundFiles(i), "\")(UBound(Split(.FoundFiles(i), "\")))
        donnees.Copy ThisWorkbook.Sheets("IMPORTATION").[A65536].End(xlUp)(2)
        a.Close False
        Set a = Nothing
        Set donnees = Nothing
        Application.CutCopyMode = False
    Next i
End With
With ThisWorkbook.Worksheets("IMPORTATION")
.Range([A1], [A65536].End(xlUp)).TextToColumns Range("A1"), xlDelimited, xlDoubleQuote, , , , , , True, ".", FieldInfo:=Array(Array(1, 5), Array(2, 9))
.Rows(1).Delete
End With
Application.ScreenUpdating = True
End Sub