Code vba macro excel 2010 import de plusieurs fichiers texte

Version imprimable

03/12/2011, 15h49
Eagle-I

Code vba macro excel 2010 import de plusieurs fichiers texte

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
03/12/2011, 18h52
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

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

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 :cry:. Merci dd'avance:mouarf:
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

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/