[Toutes versions] Code vba macro excel 2010 import de plusieurs fichiers texte [Résolu]

[Eagle-I]

Bonjour tt le monde, je suis nouveau, malheureusement, je ne viens pas pour apporter des réponses mais pour en avoir . je suis nul dans la programmation
J'ai besoin de votre aide pour un code vba pour excel-2010. Je veux un code pour automatiser l'import des fichiers txt localisés dans un même dossier sachant que le séparateur décimale dans les fichier txt est un point. J'aimerai que tous les fichiers txt dans ce dossier soit converti en plusieurs classeurs excel (1 classeur excel pour 1 fichier txt) et enregistrés dans le même dossier que les fichiers txt et chacun porte le nom de son fichiers txt correspondant ou si c'est plus simple un seul classeur excel avec plusieurs feuilles dont chacune correspond à un fichier txt et porte son nom.
Je sais pas si c'est réalisable, en tt cas merci d'avance à vous tous

[kiki29]

Salut, une recherche via Gog sur ce site devrait t'apporter une myriade de réponses : http://www.google.fr/#sclient=psy-ab...iw=830&bih=566

[Eagle-I]

Salut Kiki,
un très grand merci pour toi et tous ceux qui ont créer ces codes pour aider les gens

Salut, je reviens avec ce code pour convertir les fichiers txt vers xls, il fonctionne bien, la conversion est correcte mais , je dois lui spécifier pour chaque fichier texte le répertoire la ou il doit aller le chercher, il me manque l'enregistrement automatique, et la conversion de tout un répertoire de fichier txt en xls! est ce possible de m'éclaircir en tenant compte ce que javait décrit au départ
J'y connais rien dans la programmation et j'ai beaucoup de fichier txt à convertir . Merci dd'avance

Code :

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
Option Explicit
 
Sub Tst()
Dim Fichier As Variant
    ChDir ThisWorkbook.Path
    Fichier = Application.GetOpenFilename("Text Files (*.txt), *.txt")
        If Fichier <> False Then
        Lire Fichier
    End If
End Sub
 
Function Lire(ByVal NomFichier As String)
Dim Chaine As String
Dim Ar() As String
Dim i As Long
Dim iRow As Long, iCol As Long
Dim NumFichier As Integer
Dim Separateur  As String * 1
 
    '  Séparateur Tabulation
    Separateur = Chr(9)
 
    Cells.Clear
    NumFichier = FreeFile
    iRow = 1
 
    Open NomFichier For Input As #NumFichier
        Do While Not EOF(NumFichier)
            iCol = 1
            Line Input #NumFichier, Chaine
            Ar = Split(Chaine, Separateur)
            For i = LBound(Ar) To UBound(Ar)
                Cells(iRow, iCol) = Ar(i)
                iCol = iCol + 1
            Next
            iRow = iRow + 1
        Loop
    Close #NumFichier
End Function

[kiki29]

Salut, à tester plus à fond

Code :

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
Option Explicit
 
Private Sub Lire(ByVal sNomFichier As String)
Dim sChaine As String
Dim Ar() As String
Dim i As Long
Dim iRow As Long, iCol As Long
Dim NumFichier As Integer
Dim Separateur As String * 1
 
    Close
    Separateur = Chr(9)
 
    ShDatas.Cells.Clear
    NumFichier = FreeFile
    iRow = 1
 
    Open sNomFichier For Input As #NumFichier
        Do While Not EOF(NumFichier)
            iCol = 1
            Line Input #NumFichier, sChaine
            Ar = Split(sChaine, Separateur)
            For i = LBound(Ar) To UBound(Ar)
                ShDatas.Cells(iRow, iCol) = Ar(i)
                iCol = iCol + 1
            Next i
            iRow = iRow + 1
        Loop
    Close #NumFichier
End Sub
 
Private Sub ListeFichiers(sDossier As String)
Dim sFichier As String, sChemin As String
 
    sFichier = Dir$(sDossier & "\*.txt")
    Do While Len(sFichier) > 0
        sChemin = sDossier & "\" & sFichier
        Lire sChemin
        SaveXLS sChemin
        sFichier = Dir$()
    Loop
End Sub
 
Private Sub SaveXLS(ByVal sNomFichier As String)
Dim Ws As Worksheet, Wkb As Workbook
Dim sNomXLS As String
 
    sNomXLS = Left$(sNomFichier, InStrRev(sNomFichier, ".")) & "xls"
 
    Set Ws = ThisWorkbook.Worksheets(ShDatas.Name)
    Ws.UsedRange.Copy
 
    Set Wkb = Workbooks.Add
    With Wkb.ActiveSheet
        .Paste
        .Range("A1").Select
    End With
 
    With Application
        .CutCopyMode = False
        .DisplayAlerts = False
    End With
 
    Wkb.SaveAs Filename:=sNomXLS, FileFormat:=xlNormal
    ActiveWindow.Close
    Application.DisplayAlerts = True
 
    Set Wkb = Nothing
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
        .InitialView = msoFileDialogViewDetails
        .ButtonName = "Sélection Dossier"
        .Show
        If .SelectedItems.Count > 0 Then
            Application.ScreenUpdating = False
            ListeFichiers .SelectedItems(1)
            ShDatas.Cells.Clear
            Application.ScreenUpdating = True
        End If
    End With
End Sub
 
Sub SelFichier()
Dim sChemin As String
 
    sChemin = ThisWorkbook.Path
 
    With Application.FileDialog(msoFileDialogFilePicker)
        .InitialFileName = sChemin & "\"
        .Title = "Sélectionner le Fichier"
        .AllowMultiSelect = False
        .Filters.Clear
        .Filters.Add "Texte Tabulé", "*.txt", 1
        .InitialView = msoFileDialogViewDetails
        .ButtonName = "Sélection Fichier"
        .Show
        If .SelectedItems.Count > 0 Then
            Application.ScreenUpdating = False
            Lire .SelectedItems(1)
            SaveXLS .SelectedItems(1)
            ShDatas.Cells.Clear
            Application.ScreenUpdating = True
        End If
    End With
End Sub

ShDatas est le CodeName de Feuil1/Sheet1/Seite1 voir http://www.developpez.net/forums/d92...cel/vba-bases/