XL 2016 Convertir fichier HTML en format CSV

[debenexcel]

Bonjour,

Je sollicite votre aide pour une macro Excel. J'ai plusieurs fichiers de données en format HTML que j'aimerais les convertir en format CSV sous Excel avec une macro.
La structure du fichier HTML est la suivante:
Les titres de colonnes commencent à partir de la ligne 19.
Après la table comporte 5 colonnes. Le contenu dans la 1ère colonne est affiché sur deux lignes, j'aimerais copier le texte de la 2e ligne (si existe) dans une nouvelle colonne. Dans certaines lignes de cette première colonne la même description comporte plusieurs codes et numéros. La description est affichée une seule fois, mais le code est le même pour chaque numéro. Pour ces cas, je souhaiterais que la macro dupliquera la description pour chacune des lignes.
Un exemple de ces données est ci-joint vous donnant un aperçu sur l'input et le résultat souhaitable.

Je vous remercie d'avance de votre aide.

Cordialement,

 

[patricktoulon]

re
bonjour
oui il y a querytable aussi et tu peux choisir la table que tu veux en l'occurence la 2 ici

Sub test()
 Columns("B:B").NumberFormat = "@"
  
    With ActiveSheet.QueryTables.Add(Connection:= _
        "FINDER;file:///C:/Users/polux/Desktop/htmltocsv.html", Destination:=Range("$A$1"))
        .Name = "htmlto"
        .FieldNames = True
        .PreserveFormatting = True
         .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
          .AdjustColumnWidth = True
         .WebSelectionType = xlSpecifiedTables
        .WebFormatting = True
        .WebTables = "2"
        .WebPreFormattedTextToColumns = True
        .WebConsecutiveDelimitersAsOne = True
         .Refresh BackgroundQuery:=False
    .Delete
    End With
  Columns("B:B").NumberFormat = "@"
  
End Sub

 

[Staple1600]

Bonjour patricktoulon

•>patricktoulon
Alors, il se passe bien le confinement par chez toi ?
Je viens de tester ton code.
J'y trouve deux avantages
Comme il faut passer le temps, j'ai juste fait muse muse avec

Sub test_B()
Dim HTML_file$
HTML_file = "C:\Users\STAPLE\htmltocsv\htmltocsv.html"
With ActiveSheet.QueryTables.Add(Connection:= _
"FINDER;file:///" & HTML_file, Destination:=Cells(1))
.Name = "htmlto": .FieldNames = True: .PreserveFormatting = True
.BackgroundQuery = True: .RefreshStyle = 1
.WebSelectionType = xlSpecifiedTables: .WebTables = "2"
.WebPreFormattedTextToColumns = True: .WebConsecutiveDelimitersAsOne = True
.Refresh BackgroundQuery:=False: .Delete
End With
End Sub

Je te laisse réagencer, faut que j'aille au ravitaillement
(j'ai plus de bières!!!)

 

[patricktoulon]

oui j'arrive du dentiste
du coup je vais un peu m'amuser

Option Explicit
Function ConvertHtmlToCsv(fichier)
    Dim laChaine$, trs As Object, X&, I&, lesgosses As Object, g&, ent
    X = FreeFile: Open fichier For Binary Access Read As #X: laChaine = String(LOF(X), " "): Get #X, , laChaine: Close #X
    With CreateObject("htmlfile")
        .body.innerhtml = laChaine
        Set trs = .getelementsbytagname("TABLE")(1).getelementsbytagname("tr")
        For I = trs.Length - 2 To 0 Step -1
            If trs(I).ChildNodes.Length = 1 Then trs(I + 1).appendchild (trs(I).ChildNodes(0))
        Next
        ReDim tablo(0 To trs.Length - 1, 1 To 6)
        For I = 1 To trs.Length - 1
            If trs(I).ChildNodes.Length > 0 Then
                Set lesgosses = trs(I).ChildNodes
                For g = 0 To lesgosses.Length - 1: tablo(X, g + 1) = Trim(lesgosses(g).innertext): Next
                X = X + 1:
            End If
        Next
        Cells(1, 1).Resize(UBound(tablo), UBound(tablo, 2)) = tablo
        ent = Array("code", "ID", "Date Acqusition", "Nombre", "Dernière utilisation", "Descriptif")
        Cells(1, 1).Resize(, UBound(ent) + 1) = ent
    End With
End Function
Sub test()
    ConvertHtmlToCsv "C:\Users\polux\DeskTop\htmltocsv.html"
End Sub

faut bien passer le temps non ?
il vous reste plus qu'a déplacer les colonnes a votre guise

 

[debenexcel]

Bonjour,
Merci vous deux,
Voici le résultat obtenu en appliquant le dernier code. L'ID ne s'imprime pas en format texte, la date ne s'affiche pas dans le même format, et la description du dernier id n’apparaît pas. Le problème des cases vides est réglé. Voir capture

 

[patricktoulon]

re
le dernier descriptif est inexistant dans l'original
normalement le format est appliqué j'ai testé

 

[debenexcel]

re
Dans le fichier original, le dernier descriptif contient 2 ID, j'aimerais l'afficher pour chaque ID dans l'output csv. voir copie de l'original
pour le format, je n'ai rien changé dans le format de ma feuille, c'est le format standard par défaut pour toutes les cellules. devrais-je le mettre en texte?

 

[debenexcel]

Re
Pour le format ce n'est pas grave, il suffit de mettre les cellules en format texte, je viens de le tester.

 

[patricktoulon]

re
bonjour
voila qui te restitue ton tableau correctement

Option Explicit
Function ConvertHtmlToCsv(fichier)
    Dim laChaine$, trs As Object, X&, I&, lesgosses As Object, g&, ent, a
    X = FreeFile: Open fichier For Binary Access Read As #X: laChaine = String(LOF(X), " "): Get #X, , laChaine: Close #X
    With CreateObject("htmlfile")
        .body.innerhtml = laChaine
        Set trs = .getelementsbytagname("TABLE")(1).getelementsbytagname("tr")
        For I = trs.Length - 2 To 0 Step -1
            If trs(I).ChildNodes.Length = 1 Then trs(I + 1).appendchild (trs(I).ChildNodes(0))
        Next
        ReDim tablo(0 To trs.Length - 1, 1 To 6)
        For I = 1 To trs.Length - 1
            If trs(I).ChildNodes.Length > 0 Then
                Set lesgosses = trs(I).ChildNodes
                For g = 0 To lesgosses.Length - 1
                    If IsDate(Trim(lesgosses(g).innertext)) Then a = CDate(Trim(lesgosses(g).innertext)) Else a = Trim(lesgosses(g).innertext)
                    tablo(X, g + 1) = a: Next
                If tablo(X, 6) = "" Then tablo(X, 6) = tablo(X - 1, 6)
                X = X + 1:
            End If
        Next
        With Range("A:F"):
            .Clear
            .Columns(2).NumberFormat = "@"
            .Range("C:C,E:E").NumberFormat = "m/d/yyyy"
            Cells(1, 1).Resize(UBound(tablo), UBound(tablo, 2)) = tablo
            ent = Array("code", "ID", "Date Acqusition", "Nombre", "Dernière utilisation", "Descriptif")
            Cells(1, 1).Resize(, UBound(ent) + 1) = ent
            .EntireColumn.AutoFit
        .HorizontalAlignment = xlCenter
        End With
    End With
End Function
Sub test()
    ConvertHtmlToCsv "C:\Users\polux\DeskTop\htmltocsv.html"
End Sub

 

[Hasco]

Bonjour,

Re bonjour l' ami l'agrafe

PowerQuery étant inclus dans excel 2016 voici pour ceux que ça intéressent une solution dans le zip joint avec le fichier html source et le fichier .xlsx.

Dans la première étape nommée 'Source' de la requête, changez le chemin vers le fichier html source.

Cordialement

 

[debenexcel]

Re Roblochon
Merci! Je ne maîtrise pas PowerQuery mais il semble intéressant et répond au besoin. Mais je comprend pas, j'ai modifié la source des données, puis j'ai modifié mon fichier html en enlevant quelques données pour vérifier son comportement pour les cases vides, mais il n'a pas actualisé l'output. il affiche encore les anciennes données.
Comment régler ça?

 

[debenexcel]

RE
patricktoulon
Bonjour,
Merci!, ton dernier code fonctionne bien. Mais seulement avec le fichier test. Quand je l'ai appliqué sur mes fichiers originaux, il n'a pas fonctionné du tout. Le fichier original comporte plusieurs tables. Il a pris la première table contenant des titres. Voir un autre exemple plus conforme du fichier HTML (test.html) ainsi que l'output obtenu (capture 15).
Merci de ton aide

 

[patricktoulon]

il te faut cilbler la bonne table peut etre en testant si dans le innertext on y trouve les titres par exemple puisqu'il n'y a pas de classe ou d'ID

 

[Hasco]

Bonjour,

Sélectionnez une cellule du tableau résultat de la requête, click-droit/actualiser ou Onglet Données et bouton Actualiser tout ou bouton Actualiser

Cordialement

 

[debenexcel]

Re Roblochon
J'ai réussi à actualiser la table, mais quand je l'ai appliqué sur un autre fichier, il a affiché un message d'erreur indiquant que Description/Code n'existe pas, pourtant il existe. voir captures.
Comment faire pour régler ce problème?
Merci

 

[patricktoulon]

re
voila recherche en dom a l'ancienne

fonctionne sur les deux fichiers

Option Explicit
Function ConvertHtmlToCsv(fichier)
    Dim laChaine$, trs As Object, X&, I&, lesgosses As Object, g&, ent, a, elem
    X = FreeFile: Open fichier For Binary Access Read As #X: laChaine = String(LOF(X), " "): Get #X, , laChaine: Close #X
    With CreateObject("htmlfile")
        .body.innerhtml = laChaine
       
        For Each elem In .all
        If elem.tagname = ("TABLE") And elem.innerhtml Like "*Description/Code*" Then
               Set trs = elem.getelementsbytagname("tr"): Exit For
        End If
        Next
     
       For I = trs.Length - 2 To 0 Step -1
            If trs(I).ChildNodes.Length = 1 Then trs(I + 1).appendchild (trs(I).ChildNodes(0))
        Next
        ReDim tablo(0 To trs.Length - 1, 1 To 6)
        For I = 1 To trs.Length - 1
            If trs(I).ChildNodes.Length > 0 Then
                Set lesgosses = trs(I).ChildNodes
                For g = 0 To lesgosses.Length - 1
                    If IsDate(Trim(lesgosses(g).innertext)) Then a = CDate(Trim(lesgosses(g).innertext)) Else a = Trim(lesgosses(g).innertext)
                    tablo(X, g + 1) = a: Next
                If tablo(X, 6) = "" Then tablo(X, 6) = tablo(X - 1, 6)
                X = X + 1:
            End If
        Next
        With Range("A:F"):
            .Clear
            .Columns(2).NumberFormat = "@"
            .Range("C:C,E:E").NumberFormat = "m/d/yyyy"
            Cells(1, 1).Resize(UBound(tablo), UBound(tablo, 2)) = tablo
            ent = Array("code", "ID", "Date Acqusition", "Nombre", "Dernière utilisation", "Descriptif")
            Cells(1, 1).Resize(, UBound(ent) + 1) = ent
            .EntireColumn.AutoFit
        .HorizontalAlignment = xlCenter
        End With
    End With
End Function
Sub test()
    ConvertHtmlToCsv "C:\Users\polux\DeskTop\test.html"
End Sub