Import fichiers XML

Version imprimable

Import fichiers XML

Bonjour,

Tout est dans le titre.
Je voudrais importer une centaine de fichier XML (tous la meme structure)
et les enrgister dans un dossier au format TXT en donnant les noms suivants :
B1, B2, B3....B100 pour les fichiers TXT.

En vous remerciant par avance.

J'ai essayé avec cette Macro :
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 Sub ImporterFichierXML() Dim XM As XmlMap 'Importe le fichier dans la cellule B1 de la Feuil3. ThisWorkbook.XmlImport _ URL:="C:\Documents and Settings\Desktop\TTT_20130624_001.xml",_ ImportMap:=Nothing, _ Overwrite:=True, _ Destination:=Worksheets("A1").Range("$B$1") '.Range("$B$1") 'Définit le mappage qui vient d'être ajouté. 'ThisWorkbook.XmlMaps.Count correspond au dernier xml mappé dans le classeur Set XM = ThisWorkbook.XmlMaps(ThisWorkbook.XmlMaps.Count) MsgBox "Import terminé" & vbCrLf & _ XM.RootElementName & vbCrLf & _ XM.Name & vbCrLf & _ XM.DataBinding.SourceUrl End Sub
Mais ce code c'est que pour un seul fichier XML

Merci

Bonjour,

Une piste à explorer car je n'ai pas testé sur des .xml
La proc appelle une fonction pour récupérer les noms des fichiers portants l'extension voulue dans le dossier passé en argument ensuite, elle boucle sur le tableau de String retournés, c'est là qu'il te faut adapter à ce que tu veux faire :

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
 
Sub RecupFichiers()
 
    Dim Tbl() As String
    Dim Test As Integer
    Dim I As Integer
 
    'récupère les noms des fichiers se terminant par .xml en minuscules
    'les extensions en majuscules sont ignorées
    Tbl() = Fichiers("C:\Documents and Settings\Desktop\", ".xml")
 
    'une erreur est générée si le tableau n'est pas initialisé
    On Error Resume Next
    Test = UBound(Tbl)
 
    If Err.Number <> 0 Then
 
        MsgBox "Aucun fichier dans le dossier !"
        Err.Clear
        Exit Sub
 
    End If
 
    'boucle sur le tableau
    For I = 1 To UBound(Tbl)
 
        '!!! Ici le traitement voulu...
 
        'adapter :
        'si le classeur doit être ouvert
        'Workbooks.Open "C:\Documents and Settings\Desktop\" & Tbl
 
        'enregistrer en .txt
        'ActiveWorkbook.SaveAs "C:\Documents and Settings\Desktop\" & "B" & I & ".txt", xlUnicodeText
 
        'etc...
 
'        ThisWorkbook.XmlImport Tbl(I), Nothing, True, Worksheets("A1").Range("B1")
'        Set XM = ThisWorkbook.XmlMaps(ThisWorkbook.XmlMaps.Count)
'        MsgBox "Import terminé" & vbCrLf & _
'            XM.RootElementName & vbCrLf & _
'            XM.Name & vbCrLf & _
'            XM.DataBinding.SourceUrl
 
 
    Next I
 
End Sub
 
'Cette fonction retourne les noms des fichiers présents dans le dossier
'et ayant l'extension voulue dans un tableau String
Function Fichiers(Chemin As String, _
                  Extension As String) As String()
 
    Dim Tbl() As String
    Dim Fich As String
    Dim I As Integer
 
    Fich = Dir(Chemin)
 
    Do While (Len(Fich) > 0)
 
        'seuls les fichiers avec l'extension voulue
        If InStr(Fich, Extension) <> 0 Then
 
            I = I + 1
            ReDim Preserve Tbl(1 To I)
            Tbl(I) = Fich
 
        End If
 
        Fich = Dir()
 
    Loop
 
    Fichiers = Tbl()
 
End Function

Hervé.

Bonjour Theze, id301077

Si je me permet de proposer une petite amélioration dans la fonction proposée

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
Private Function Fichiers(Chemin As String, Extension As String) As String()
Dim Tbl() As String, Fich As String
Dim i As Integer
 
If Right(Chemin, 1) <> "\" Then Chemin = Chemin & "\"
Fich = Dir(Chemin & "*." & Extension)
Do While Len(Fich) > 0
    i = i + 1
    ReDim Preserve Tbl(1 To i)
    Tbl(i) = Chemin & Fich
    Fich = Dir()
Loop
Fichiers = Tbl()
End Function

29/06/2013, 14h27
Theze

Bonjour mercatog,

Toute amélioration est toujours bienvenue ;o)

Hervé.