import fichiers XML

Version imprimable

import fichiers XML

bonjour à tous,

je dois importer plusieurs fichiers XML d'un même répertoire bout à bout dans une feuille excel.

voici le code qui fonctionne pour un fichier.
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 Sub ImportJanvier() ' ' ImportJanvier Macro ' Macro enregistrée le 30/09/2013 par plancotd ' ' Sheets("janvier").Select Range("B8").Select ActiveWorkbook.XmlMaps("Root_Mappage").Import URL:= _ "N:\MOYENS GENERAUX\Imprimerie\FichiersXMLindicateurs\XML\COM-2013\janvier\sandra.xml" ' ActiveWindow.SmallScroll Down:=2 End Sub
comment le modifier pour qu'il importe les autres fichiers du répertoire à la suite?

merci

01/10/2013, 13h38
Marc-L

Bonjour,

en adaptant l'exemple de l'aide de la fonction Dir …

Sinon il y a aussi la Manipulation des fichiers en VBA même si Dir doit suffire.

Bonjour,

Il te suffit de récupérer la ligne de la dernière cellule remplie de la feuille à chaque fois que tu changes xml, par exemple (et à adapter):

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 ImportJanvier()
'
' ImportJanvier Macro
' Macro enregistrée le 30/09/2013 par plancotd
'
Dim myWS as worksheet 
'
    Set myWS = activeworkbook.worksheets("janvier")
    myWS.range("B8").Select
 
    ActiveWorkbook.XmlMaps("Root_Mappage").Import URL:= _
        "N:\MOYENS GENERAUX\Imprimerie\FichiersXMLindicateurs\XML\COM-2013\janvier\sandra.xml"
 
 
 
' Ces deux lignes sont à répéter autant de fois qu'il y aura de fichier à coller à la suite
 
        myWS.range("B"&myws.usedrange.rows.count+1).Select    
        "N:\MOYENS GENERAUX\Imprimerie\FichiersXMLindicateurs\XML\COM-2013\janvier\XXXXXX.xml"
 
 
 
 
 
End Sub

01/10/2013, 13h43
Marc-L

Oui effectivement, j'avais oublié l'ajout bout à bout … :oops:
01/10/2013, 13h47
danval25

j'ai une erreur de syntax sur la derniére ligne?

Essaie ça:

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
Sub test()
    Dim oFSO As Scripting.FileSystemObject
    Dim oFld As Scripting.Folder
    Dim oFile As Scripting.File
    Dim strChemin As String
    Dim IsFirstLoop As Boolean
 
    strChemin = "N:\MOYENS GENERAUX\Imprimerie\FichiersXMLindicateurs\XML\COM-2013\janvier\"
    firstLoop = True
    Set oFSO = New Scripting.FileSystemObject
    Set oFld = oFSO.GetFolder(strChemin)
 
    For Each oFile In oFld.Files
        If oFile.Name Like "*.xml" Then
            If IsFirstLoop = True Then
                Sheets("janvier").Select
                ActiveSheet.Range("B8").Select
                ActiveWorkbook.XmlMaps("Root_Mappage").Import URL:=strChemin & oFile.Name
                IsFirstLoop = False
            Else
                Sheets("janvier").Select
                ActiveSheet.Range("B" & Sheets("janvier").UsedRange.Rows.Count + 1).Select
                ActiveWorkbook.XmlMaps("Root_Mappage").Import URL:=strChemin & oFile.Name
            End If
        End If
    Next oFile
    Set oFSO = Nothing
    Set oFld = Nothing
    Set oFile = Nothing
 
End Sub

01/10/2013, 14h43
danval25

je viens d'essayer:

message d'erreur sur les 3 premiéres ligne:

type defini par l'utilisateur non defini
01/10/2013, 14h45
SMBeccaria

yes

ouvre ton classeur puis
Alt+F11 => Outils => Références => Et tu coches "Microsoft Sscripting Runtime"

après ça, ça devrait foncer
01/10/2013, 15h18
danval25

4 pièce(s) jointe(s)

ok la macro tourne mais je n'ais que le premier fichier qui est visible le deuxiéme ne s'affiche pas?

j'ai peut-être fait une erreur dans la conception de mon fichier?

je joins mon fichier excel et les deux xml et le mappage.

je n'y connais rien alors je regarde les forum pour faire mais là trop dur pour moi.

Pièce jointe 127905

Pièce jointe 127907

Pièce jointe 127908

Pièce jointe 127909

Bonjour Danval,

J'ai pu me repencher sur le sujet qui n'est pas si trivial que cela...et j'ai sorti cette proc qui marche chez moi, je te laisse l'essayer:

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
Option Explicit
 
Sub test()
    Dim oFSO As Scripting.FileSystemObject
    Dim oFld As Scripting.Folder
    Dim oFile As Scripting.File
    Dim strChemin As String
    Dim IsFirstLoop As Boolean
    Dim i As Long, x As Long
 
    strChemin = "N:\MOYENS GENERAUX\Imprimerie\FichiersXMLindicateurs\XML\COM-2013\janvier\"
    Set oFSO = New Scripting.FileSystemObject
    Set oFld = oFSO.GetFolder(strChemin)
    x = ActiveWorkbook.XmlMaps.Count
    If Not x = 0 Then
        Do
            ActiveWorkbook.XmlMaps(x).Delete
            x = x - 1
        Loop Until x = 0
    End If
    x = ActiveWorkbook.Connections.Count
    If Not x = 0 Then
        Do
            ActiveWorkbook.Connections(x).Delete
        x = x - 1
        Loop Until x = 0
    End If
    ActiveWorkbook.Worksheets("janvier").Activate
    ActiveSheet.Cells.ClearContents
    ActiveSheet.Cells.Delete
    Application.DisplayAlerts = False
    For Each oFile In oFld.Files
        If oFile.Name Like "*.xml" Then
            ActiveWorkbook.XmlImport URL:= _
                oFile, ImportMap:=Nothing, _
                Overwrite:=True, Destination:=Range("B" & ActiveSheet.UsedRange.Rows.Count + 20)
        End If
 
    Next oFile
    Application.DisplayAlerts = True
    Set oFSO = Nothing
    Set oFld = Nothing
    Set oFile = Nothing
 
End Sub

By the way, méfiance avec les noeuds vides du fichier xml qui agrandissent d'autant la plage du tableau de sortie et puisque mon usedrange ne localise pas ce que je souhaite, cela pourra poser pb.

J'ai pris une sécurité de 20 lignes mais si jamais une erreur apparaît, tu peux essayer soit de liquider les noeuds vides de l'xml, soit d'augmenter ce buffer.

2 pièce(s) jointe(s)

merci beaucoup mais j'ai enfin trouvé la solution à mon problème ce matin.

voila mon code d'importation:

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
Sub ExportDesDonneesXML()
 
On Error Resume Next
 
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayAlerts = False
 
Dim Chemin As String
Dim Nom As String
Dim Fichier As String
Dim numfile As Integer
Dim i As Integer
 
Chemin = "N:\MOYENS GENERAUX\Imprimerie\FichiersXMLindicateurs\XML\communication\janvier\"
Nom = ActiveWorkbook.Name
Nom = Split(Nom, ".")(0)                                            'On prend le nom du fichier courant sans son extension .xls
Fichier = Chemin & Nom & ".xml"
 
numfile = FreeFile
Open Fichier For Output As #numfile
Print #numfile, "<?xml version='1.0'  encoding='ISO-8859-1' ?>"
Print #numfile, "<releves>"
i = 10
    While Cells(i, 6) <> ""
        Print #numfile, "<factures>"
            Print #numfile, "<numFacture>" & Cells(i, 1) & "</numFacture>"
            Print #numfile, "<date>" & Cells(i, 2) & "</date>"
            Print #numfile, "<C>" & Cells(i, 3) & "</C>"
            Print #numfile, "<service>" & Cells(i, 4) & "</service>"
            Print #numfile, "<numero>" & Cells(i, 5) & "</numero>"
            Print #numfile, "<intitule>" & Cells(i, 7) & "</intitule>"
            Print #numfile, "<machine>" & Cells(i, 8) & "</machine>"
            Print #numfile, "<couleur>" & Cells(i, 9) & "</couleur>"
            Print #numfile, "<rectoVerso>" & Cells(i, 10) & "</rectoVerso>"
            Print #numfile, "<brochure>" & Cells(i, 11) & "</brochure>"
            Print #numfile, "<formatFini>" & Cells(i, 12) & "</formatFini>"
            Print #numfile, "<nbreDePages>" & Cells(i, 13) & "</nbreDePages>"
            Print #numfile, "<attente>" & Cells(i, 14) & "</attente>"
            Print #numfile, "<nbreDExemplaires>" & Cells(i, 15) & "</nbreDExemplaires>"
            Print #numfile, "<O>" & Cells(i, 16) & "</O>"
            Print #numfile, "<papier>" & Cells(i, 17) & "</papier>"
            Print #numfile, "<Q>" & Cells(i, 18) & "</Q>"
            Print #numfile, "<typeDePapier>" & Cells(i, 19) & "</typeDePapier>"
            Print #numfile, "<S>" & Cells(i, 20) & "</S>"
            Print #numfile, "<NbreDeFeuilles>" & Cells(i, 21) & "</NbreDeFeuilles>"
            Print #numfile, "<feuillesOffset>" & Cells(i, 22) & "</feuillesOffset>"
            Print #numfile, "<V>" & Cells(i, 23) & "</V>"
            Print #numfile, "<NbreDeTours>" & Cells(i, 24) & "</NbreDeTours>"
            Print #numfile, "<X>" & Cells(i, 25) & "</X>"
            Print #numfile, "<montage>" & Cells(i, 26) & "</montage>"
            Print #numfile, "<Z>" & Cells(i, 27) & "</Z>"
            Print #numfile, "<NbreDePlaques>" & Cells(i, 28) & "</NbreDePlaques>"
            Print #numfile, "<AB>" & Cells(i, 29) & "</AB>"
            Print #numfile, "<NbreDexPlies>" & Cells(i, 30) & "</NbreDexPlies>"
            Print #numfile, "<Perfos>" & Cells(i, 31) & "</Perfos>"
            Print #numfile, "<NbreDexAssembles>" & Cells(i, 32) & "</NbreDexAssembles>"
            Print #numfile, "<miseSousPlis>" & Cells(i, 33) & "</miseSousPlis>"
            Print #numfile, "<AG>" & Cells(i, 34) & "</AG>"
            Print #numfile, "<couleur2>" & Cells(i, 35) & "</couleur2>"
            Print #numfile, "<prix>" & Cells(i, 36) & "</prix>"
        Print #numfile, "</factures>"
        i = i + 1
    Wend
 
Print #numfile, "</releves>"
Close #numfile
 
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.DisplayAlerts = True
 
If (Err.Number <> 0) Then GoTo plantage   'gestion des erreurs afin de prévenir l'utilisateur
 
MsgBox "Les données XML ont bien été exportées.", vbOKOnly + vbInformation, "Message"
 
Exit Sub
 
plantage:
MsgBox "Une erreur s'est produite : l'export des données ne s'est pas passé correctement !", vbCritical
 
End Sub

il fonctionne sur la feuille de janvier qui possède un mappage.

j'ai donc fait une copie pour les onze autres mois.

elles ont toute la même structure et le même mappage.

il y a deux choses que je n'arrive pas à faire:

1 _ étendre la macro à toute les feuilles: charger les xml du dossier février dans la feuille février,...

2 - lorsque je lance la macro elle ajoute le contenu des fichiers xml dans la feuille à la suite de ce qu'il y as déjà.
le problème est que le fichier importé est dèja présent dedans donc il y as doublon.
ce qu'il faudrait s'est effacer les feuilles avant de procédé à l'import.

comme il y as un mappage j'ai un cadre bleu qui suit les données et je n'arrive pas à faire un effaçage.

je joint un XML et mon fichier import avec la macro dedans.

macro import:

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
Sub ActuDonneesClasseur()
'
' ActuDonneesClasseur Macro
' Macro enregistrée le 09/04/2013 par plancot daniel
'
 
'
On Error Resume Next
 
Application.EnableEvents = False
Application.DisplayAlerts = False
Application.ScreenUpdating = False
 
Dim Repertoire As String
Dim Fichier As String
Dim ws As Worksheet
 
'-------------- Retrait de la protection de tous les onglets ------------------------
For Each ws In ThisWorkbook.Worksheets
    ws.Unprotect Password:=""
Next ws
 
ActiveWorkbook.XmlMaps("commandesFournitures_Mappage").DataBinding.Refresh          'Appel pour mise à jour des données XML
 
Repertoire = "N:\MOYENS GENERAUX\Imprimerie\FichiersXMLindicateurs\xml\communication\janvier\"
Fichier = Dir(Repertoire & "*.xml")                                                 ' recherche des fichiers .xml dans le répertoire FichiersXMLindicateurs
 
While Fichier <> ""                                                                 ' On importe les données de tous les fichiers xml trouvés dans le mappage releves_Travaux_Imprimerie
    ThisWorkbook.XmlMaps("releves_Travaux_Imprimerie").Import URL:=Repertoire & Fichier
    If (Err.Number = 0) Then Kill (Repertoire & Fichier)                            'S'il n'y a pas eu de pb, une fois l'importation réalisée on suprime le fichier XML afin d'éviter les redondances de données
    Fichier = Dir()
Wend
 
 
    ActiveWorkbook.RefreshAll                                                       'Mise à jour de toutes les requêtes et des TxD
 
'------------------------ Remise en place de la protection des onglets ----------------
For Each ws In ThisWorkbook.Worksheets
    ws.Protect Password:="", DrawingObjects:=False, Contents:=True, Scenarios:=True _
        , UserInterfaceOnly:=True, AllowFormattingCells:=True, AllowFormattingColumns:=True, _
        AllowSorting:=True, AllowFiltering:=True, AllowUsingPivotTables:=True
Next ws
 
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.DisplayAlerts = True
 
If (Err.Number <> 0) Then GoTo plantage    'gestion des erreurs afin de prévenir l'utilisateur
 
MsgBox "Toutes les données ont été actualisées.", vbOKOnly + vbInformation, "Message"
 
Exit Sub
 
plantage:
MsgBox "Une erreur s'est produite : la mise à jour des données a échouée.", vbCritical
 
End Sub

Pièce jointe 128071

Pièce jointe 128072

05/10/2013, 20h07
danval25

bonjour à tous,

j'ai bien travaillé il ne me manque plus qu'une petite fonction que j'ai expliqué dans un autre post.

je cloture donc ce post en remerciant ceux qui m'ont aidés à avancer.

Daniel