Discussion :

[jb.43]

Bonjour à tous,

Je cherche à développer une macro me permettant d'importer automatiquement des fichiers .txt situés dans un même répertoire vers un seul et même classeur excel.

Les fichiers sont tout le temps de la même structure que celui-ci: T3H-5878_2017-10-14_220051.txt

Autrement dit, l'en-tête est toujours la même.

Je souhaiterais donc que lors de l'import, ces fichiers soient mis les uns à la suite des autres, sans reprendre l'en-tête à chaque fois.

Idéalement, il faudrait aussi que la macro me demande dans quel répertoire je souhaite aller chercher les fichiers.

Malgré les nombreuses discussions à ce sujet, je ne parviens pas à résoudre mon problème.

Désolé donc si je fais doublon et merci par avance pour votre aide..

JB

[Invité]

Bonjour,

C'est du VBA Word, mais cela ressemble à ce que vous souhaitez faire, à vous de voir si cela peut vous intéresser : word-vba-concatener-fichiers-dat-sauvegarde-rtf-partir-document-word-docm

[Menhir]

Lire la FAQ et les sources :
https://excel.developpez.com/faq/?pa...BoucleFichiers
https://excel.developpez.com/sources...oupeTxtFeuille
https://excel.developpez.com/sources...XT#CompilerTxt

[jb.43]

Merci pour vos réponses.

En creusant dans ces sources, j'ai trouvé ce code:

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
Sub on_y_va()
    Dim Repertoire As FileDialog, monRepertoire As String
    Set Repertoire = Application.FileDialog(msoFileDialogFolderPicker)
    Repertoire.Show
    If Repertoire.SelectedItems.Count > 0 Then
        monRepertoire = Repertoire.SelectedItems(1)
        fichs = Dir(monRepertoire & "\*.txt")
        Do While fichs <> ""
            aspire CStr(monRepertoire & "\" & fichs)
            fichs = Dir
        Loop
        Columns("A:A").TextToColumns Destination:=Range("A1"), Space:=False
    Else
        MsgBox "Aucun Répertoire Sélectionné"
    End If
End Sub
 
Sub aspire(fichier)
    If Right(fichier, 4) = ".txt" Then
        N = FreeFile
        Open fichier For Input As #N
        i = Cells(Rows.Count, 1).End(xlUp).Row
        Do While Not EOF(1)
            Line Input #N, contenu
            i = i + 1
            Cells(i, 1).Value = contenu
        Loop
        Close #N
    End If
End Sub

Il y a déjà du progrès.

Le problème est que le résultat en sortie est le suivant: résultat_1.xlsx

Autrement dit, les fichiers sont tous les uns à la suite des autres.

Je voudrais que la première ligne de propriété de fichier soit supprimée et que le nom des colonnes ne soit pas répété à chaque fois.

Je ne trouve pas du tout la solution, ou du moins je n'y vois pas très clair dans les propositions sur les différentes discussions.

Pouvez-vous m'aider svp ?

Merci.

[Invité]

Bonsoir,
https://www.developpez.net/forums/d1.../#post10008042

[jb.43]

Bonsoir,
https://www.developpez.net/forums/d1.../#post10008042

Désolé mais étant complètement novice en VBA je n'y vois pas plus clair.

[78chris]

Bonjour

Sur 2013 tu peux installer PowerQuery (add on gratuit Microsoft qui l'a intégré à partir de 2016) tu peux faire cela simplement sans coder en VBA.

[jb.43]

Bonjour

Sur 2013 tu peux installer PowerQuery (add on gratuit Microsoft qui l'a intégré à partir de 2016) tu peux faire cela simplement sans coder en VBA.

Bonsoir.

Effectivement je viens de découvrir ça. Cela répond parfaitement à mes besoins.

Merci beaucoup !

[SBAY3I]

salut tous
peut-être que ce site Web vous aidera @jb.43
http://boisgontierjacques.free.fr/

[Invité]

Bonjour,

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
 
Const DATAOBJECT_BINDING As String = "new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}"
 
Sub on_y_va()
    Dim Repertoire As FileDialog, monRepertoire As String
    Set Repertoire = Application.FileDialog(msoFileDialogFolderPicker)
    Repertoire.Show
    If Repertoire.SelectedItems.Count > 0 Then
        monRepertoire = Repertoire.SelectedItems(1)
        fichs = Dir(monRepertoire & "\*.txt")
        Do While fichs <> ""
            aspire CStr(monRepertoire & "\" & fichs)
            fichs = Dir
        Loop
        Columns("A:A").TextToColumns Destination:=Range("A1"), Space:=False
    Else
        MsgBox "Aucun Répertoire Sélectionné"
    End If
End Sub
*
Sub aspire(fichier)
    If Right(fichier, 4) = ".txt" Then
i = Cells(Rows.Count, 1).End(xlUp).Row
 
       Open FICHIER For Input As #1
 PressePapier = Input(LOF(1), #1)
Close #1
If i >1 then i=i+1
Cells(i,"A").PasteSpecial xlPasteAll
Rows(i & ":" & i +1).delete
If i>1 then rows(i).delete
 
    End If
End Sub
Public Property Let PressePapier(Value)
    With CreateObject(DATAOBJECT_BINDING)
        .SetText Value
        .PutInClipboard
    End With
End Property
 
Public Property Get PressePapier()
    With CreateObject(DATAOBJECT_BINDING)
        .GetFromClipboard
        PressePapier = .GetText
    End With
End Property

[jb.43]

Bonjour,

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
 
Const DATAOBJECT_BINDING As String = "new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}"
 
Sub on_y_va()
    Dim Repertoire As FileDialog, monRepertoire As String
    Set Repertoire = Application.FileDialog(msoFileDialogFolderPicker)
    Repertoire.Show
    If Repertoire.SelectedItems.Count > 0 Then
        monRepertoire = Repertoire.SelectedItems(1)
        fichs = Dir(monRepertoire & "\*.txt")
        Do While fichs <> ""
            aspire CStr(monRepertoire & "\" & fichs)
            fichs = Dir
        Loop
        Columns("A:A").TextToColumns Destination:=Range("A1"), Space:=False
    Else
        MsgBox "Aucun Répertoire Sélectionné"
    End If
End Sub
*
Sub aspire(fichier)
    If Right(fichier, 4) = ".txt" Then
i = Cells(Rows.Count, 1).End(xlUp).Row
 
       Open FICHIER For Input As #1
 PressePapier = Input(LOF(1), #1)
Close #1
If i >1 then i=i+1
Cells(i,"A").PasteSpecial xlPasteAll
Rows(i & ":" & i +1).delete
If i>1 then rows(i).delete
 
    End If
End Sub
Public Property Let PressePapier(Value)
    With CreateObject(DATAOBJECT_BINDING)
        .SetText Value
        .PutInClipboard
    End With
End Property
 
Public Property Get PressePapier()
    With CreateObject(DATAOBJECT_BINDING)
        .GetFromClipboard
        PressePapier = .GetText
    End With
End Property

Bonjour et merci beaucoup ! cela fonctionne très bien