Export XML en macro

Le 28/01/2022 à 15:12

Bonjour tout le monde,

Après avoir longuement cherché et testé bon nombre de choses, je me tourne vers vous car mon besoin semble bien spécifique...

Je travail sur un classeur Excel ayant pour but de planifier une grille des programmes pour une chaine de TV locale.

Maintenant j'aurais besoin de pouvoir généré à partir de la première feuille de mon classeur (le récapitulatif du programme de la semaine) un fichier XML reprenant les entêtes de colonnes comme balises.

Comme nous sommes plusieurs à exploiter ce document j'ai besoin de pouvoir faire cet export via une Macro et malheureusement je n'arrive à rien ...
De plus cet export devra intégrer des règles quant au contenu des lignes car tout ne devra pas être exporté. (Oui pourquoi faire simple ?)

Tout ce qui est "PUB" ainsi que "Comblage / BA" ne doivent pas apparaître dans cet export.

En vous remerciant par avance pour votre aide, très bonne fin de journée.

Je vous met dans ce post le fichier en question.

19grille-standard-2022.zip (1.06 Mo)
Le 11/02/2022 à 17:20

Je me permet un petit UP de ce topic avec une mise à jour du fichier concerné.

14grille-standard-cg-cm-2022.zip (1.03 Mo)
Le 12/02/2022 à 00:16

bonsoir,

as-tu un exemple de fichier XML qu'il faudrait générer sur base de ces données ?

Le 14/02/2022 à 11:56

Bonjour,

Oui bien-sûr !

<?xml version="1.0" encoding="UTF-8"?>
<Grille-des-programmes>
    <Day day="Lundi">
        <Date>14.02.2022</Date>
        <Heure-IN>08:00</Heure-IN>
        <Heure-OUT>08:30</Heure-OUT>
        <Duree>30</Duree>
        <ID>GVASHOW-110222-rediff</ID>
        <Titre-Emission>Geneva Show - Le grand entretien</Titre-Emission>
        <Description>Description de l'émission</Description>
        <Type-de-Diffusion>Rediff</Type-de-Diffusion>
        <ID-WEB>2000</ID-WEB>
    </Day>
    [etc ...]
</Grille-des-programmes>
Le 14/02/2022 à 13:24

bonjour,

une proposition

Sub export_XML()
    '    <XML version="1.0" encoding="UTF-8">
    '<Grille-des-programmes>
    '    <Day day="Lundi">
    '        <Date>14.02.2022</Date>
    '        <Heure-IN>08:00</Heure-IN>
    '        <Heure-OUT>08:30</Heure-OUT>
    '        <Duree>30</Duree>
    '        <ID>GVASHOW-110222-rediff</ID>
    '        <Titre-Emission>Geneva Show - Le grand entretien</Titre-Emission>
    '        <Description>Description de l'émission</Description>
    '        <Type-de-Diffusion>Rediff</Type-de-Diffusion>
    '        <ID-WEB>2000</ID-WEB>
    '    </Day>
    '[etc ...]
    With Application.FileDialog(msoFileDialogSaveAs)
        .AllowMultiSelect = False
        .Title = "Name of the XML file"
        If .Show = True Then
            fname = .SelectedItems(1)
        Else
            MsgBox "no files selected"
        End If
    End With
    Dim fsT As Object
    XMLstring = "<XML version=""1.0"" encoding=""UTF-8"">" & vbNewLine & "<Grille-des-programmes>"
    For Each ws In ThisWorkbook.Worksheets
        Select Case ws.Name
            Case "Lundi", "Mardi", "Mercredi", "Jeudi", "Vendredi", "Samedi", "Dimanche"
                With ws
                    DL = .Cells(Rows.Count, 1).End(xlUp).Row
                    For i = 3 To DL
                        XMLstring = XMLstring & vbNewLine & vbTab & "<Day day=""" & ws.Name & """>"
                        For col = 1 To 9
                            If .Cells(i, col) <> "" Then XMLstring = XMLstring & vbNewLine & vbTab & vbTab & "<" & .Cells(2, col) & ">" & .Cells(i, col).Text & "</" & .Cells(2, col) & ">"
                        Next col
                        XMLstring = XMLstring & vbNewLine & vbTab & "</Day>"
                    Next i
                End With
        End Select
    Next ws
    XMLstring = XMLstring & vbNewLine & "</Grille-des-programmes>" & vbNewLine & "</XML>"
    Set FXML = CreateObject("ADODB.Stream")
    FXML.Type = 2
    FXML.Charset = "utf-8"
    FXML.Open
    FXML.WriteText XMLstring
    FXML.SaveToFile fname, 2
    MsgBox "fichier " & fname & " créé"
End Su
Le 14/02/2022 à 13:49

Bonjour, merci beaucoup tout d'abord !

Visiblement il ne reconnait pas .AllowMultiSelect

capture d ecran 2022 02 14 a 13 48 17
Le 14/02/2022 à 14:01

bonjour,

pas de problème chez moi. Mais tu peux supprimer cette instruction

Le 14/02/2022 à 14:09

C'est curieux...
Je dois implanter la fonction dans un nouveau module ?

Le 14/02/2022 à 14:13

il semblerait que ça soit même avant

capture d ecran 2022 02 14 a 14 11 56

J'ai tenté de supprimer la ligne AllowMultipleSelect

Le 14/02/2022 à 14:17

bonjour,

voici ton fichier avec la macro (à lancer via alt-F8)

30copy-of-grille-standard-cg-cm-2022.zip (1.03 Mo)
Le 14/02/2022 à 14:27

Je viens de downloader le fichier et même erreur chez moi

capture d ecran 2022 02 14 a 14 26 14

Est-ce que ça pourrait venir d'un problème de version d'excel ou du fait que je sois sous Mac ?

Le 14/02/2022 à 15:57

bonjour,

en effet, la macro utilise des instructions non disponibles sur mac.

voici une alternative qui devrait fonctionner sur mac. adapter éventuellement la manière dont on nomme le fichier XML et vérifier s'il ne faudra modifer le paramètre encoding dans l'entête du fichier xml.

Sub export_XML()
    fname = "nomdufichier.xml" '<- à adapter
    Dim fsT As Object
    XMLstring = "<XML version=""1.0"" encoding=""UTF-8"">" & vbNewLine & "<Grille-des-programmes>"
    For Each ws In ThisWorkbook.Worksheets
        Select Case ws.Name
            Case "Lundi", "Mardi", "Mercredi", "Jeudi", "Vendredi", "Samedi", "Dimanche"
                With ws
                    DL = .Cells(Rows.Count, 1).End(xlUp).Row
                    For i = 3 To DL
                        XMLstring = XMLstring & vbNewLine & vbTab & "<Day day=""" & ws.Name & """>"
                        For col = 1 To 9
                            If .Cells(i, col) <> "" Then XMLstring = XMLstring & vbNewLine & vbTab & vbTab & "<" & .Cells(2, col) & ">" & .Cells(i, col).Text & "</" & .Cells(2, col) & ">"
                        Next col
                        XMLstring = XMLstring & vbNewLine & vbTab & "</Day>"
                    Next i
                End With
        End Select
    Next ws
    XMLstring = XMLstring & vbNewLine & "</Grille-des-programmes>" & vbNewLine & "</XML>"
    Open fname For Output As 1
    Print #1, XMLstring
    Close 1
    MsgBox "fichier " & fname & " créé"
End Sub
Le 14/02/2022 à 16:11

Un fichier est bien créé, toute fois impossible de l'ouvrir

capture d ecran 2022 02 14 a 16 11 16
Le 14/02/2022 à 16:18

ça venait du nom du fichier "_" posait problème !

ça fonctionne, toutefois je me rends compte d'un petit problème avec le fichier généré. Serait-il possible d'exclure certaines lignes des tableaux en fonction du contenu de la colonne F ?

Je m'explique : En l'état toutes les données sont ressorties, y compris les blocs de pub ou les bandes annonces. Pour le coup ce sont des données que je ne dois pas voir apparaître.

En vous remerciant par avance,

Le 14/02/2022 à 18:49

bonsoir,

une version pour exclure les lignes PUB et comblage

Sub export_XML()
    fname = "nomdufichier.xml" '<- à adapter
    Dim fsT As Object
    XMLstring = "<XML version=""1.0"" encoding=""UTF-8"">" & vbNewLine & "<Grille-des-programmes>"
    For Each ws In ThisWorkbook.Worksheets
        Select Case ws.Name
            Case "Lundi", "Mardi", "Mercredi", "Jeudi", "Vendredi", "Samedi", "Dimanche"
                With ws
                    DL = .Cells(Rows.Count, 1).End(xlUp).Row
                    For i = 3 To DL
                        If .Cells(i, 6) <> "PUB" And .Cells(i, 6) <> "Comblage / BA" Then 'exclure PUB et comblage / BA
                            XMLstring = XMLstring & vbNewLine & vbTab & "<Day day=""" & ws.Name & """>"
                            For col = 1 To 9
                                If .Cells(i, col) <> "" Then XMLstring = XMLstring & vbNewLine & vbTab & vbTab & "<" & .Cells(2, col) & ">" & .Cells(i, col).Text & "</" & .Cells(2, col) & ">"
                            Next col
                            XMLstring = XMLstring & vbNewLine & vbTab & "</Day>"
                        End If
                    Next i
                End With
        End Select
    Next ws
    XMLstring = XMLstring & vbNewLine & "</Grille-des-programmes>" & vbNewLine & "</XML>"
    Open fname For Output As 1
    Print #1, XMLstring
    Close 1
    MsgBox "fichier " & fname & " créé"
End Sub
Le 14/02/2022 à 20:09

Merci beaucoup, je testerai ça demain matin !

En vous souhaitant une très belle soirée,

Le 15/02/2022 à 08:26

C'est parfait !

J'ai encore un dernier soucis qui concerne l'affichage des caractères accentués. J'ai testé le iso-8859-1 à la place de UTF-8 maille problème est toujours là.

Une idée ?

capture d ecran 2022 02 15 a 08 21 57
Le 15/02/2022 à 09:40

bonjour,

peux-tu mettre le fichier xml qui a été créé ? ne pas l'ouvrir avec un autre programme.

Le 15/02/2022 à 10:18

Voilà la fichier qui est généré

10programme.zip (9.97 Ko)
Le 15/02/2022 à 10:40

bonjour,

essaie ceci

Sub export_XML()
    fname = "d:\downloads\programme.xml" '<- à adapter
    Dim fsT As Object
    XMLstring = "<XML version=""1.0"" encoding=""UTF-8"">" & vbNewLine & "<Grille-des-programmes>"
    For Each ws In ThisWorkbook.Worksheets
        Select Case ws.Name
            Case "Lundi", "Mardi", "Mercredi", "Jeudi", "Vendredi", "Samedi", "Dimanche"
                With ws
                    DL = .Cells(Rows.Count, 1).End(xlUp).Row
                    For i = 3 To DL
                        If .Cells(i, 6) <> "PUB" And .Cells(i, 6) <> "Comblage / BA" Then 'exclure PUB et comblage / BA
                            XMLstring = XMLstring & vbNewLine & vbTab & "<Day day=""" & ws.Name & """>"
                            For col = 1 To 9
                                If .Cells(i, col) <> "" Then XMLstring = XMLstring & vbNewLine & vbTab & vbTab & "<" & .Cells(2, col) & ">" & .Cells(i, col).Text & "</" & .Cells(2, col) & ">"
                            Next col
                            XMLstring = XMLstring & vbNewLine & vbTab & "</Day>"
                        End If
                    Next i
                End With
        End Select
    Next ws
    XMLstring = XMLstring & vbNewLine & "</Grille-des-programmes>" & vbNewLine & "</XML>"
    Open fname For Output As 1
    Print #1, Encode_UTF8(XMLstring)
    Close 1
    MsgBox "fichier " & fname & " créé"
End Sub
Public Function Encode_UTF8(astr)
    Dim c
    Dim n
    Dim utftext

    utftext = ""
    n = 1
    Do While n <= Len(astr)
        c = AscW(Mid(astr, n, 1))
        If c < 128 Then
            utftext = utftext + Chr(c)
        ElseIf ((c >= 128) And (c < 2048)) Then
            utftext = utftext + Chr(((c \ 64) Or 192))
            utftext = utftext + Chr(((c And 63) Or 128))
        ElseIf ((c >= 2048) And (c < 65536)) Then
            utftext = utftext + Chr(((c \ 4096) Or 224))
            utftext = utftext + Chr((((c \ 64) And 63) Or 128))
            utftext = utftext + Chr(((c And 63) Or 128))
            Else ' c >= 65536
                utftext = utftext + Chr(((c \ 262144) Or 240))
                utftext = utftext + Chr(((((c \ 4096) And 63)) Or 128))
                utftext = utftext + Chr((((c \ 64) And 63) Or 128))
                utftext = utftext + Chr(((c And 63) Or 128))
            End If
            n = n + 1
        Loop
        Encode_UTF8 = utftext
End Function
Rechercher des sujets similaires à "export xml macro"