Convertir un tableau HTML en Excel en utilisant VBA

Question

Convertir un tableau HTML en Excel

Le code ci-dessous récupère le tableau HTML sur https://rasmusrhl.github.io/stuff, et le convertit en format Excel.

Le problème est que :

• Les nombres entre parenthèses sont convertis en nombres négatifs
• Les nombres sont arrondis ou tronqués

Solution

Merci à tous pour vos excellentes contributions. Les réponses variées m'ont permis de comprendre que, pour mes besoins, une solution de contournement était la meilleure solution : Comme je génère moi-même les tableaux HTML, je peux contrôler le CSS de chaque cellule. Il existe des codes CSS qui indiquent à Excel comment interpréter le contenu des cellules : http://cosicimiento.blogspot.dk/2008/11/styling-excel-cells-with-mso-number.html, également expliqué dans cette question : Format de cellule de tableau HTML pour que Excel le formate en texte ?

Dans mon cas, le CSS devrait être du texte, qui est mso-number-format:\"\\@\". Il est intégré dans le code R ci-dessous :

library(htmlTable)
library(nycflights13)
library(dplyr)

nycflights13::planes %> 
    slice(1:10) %> mutate( seats = seats*1.0001,
                            s1    = c("1-5", "5-10", "1/2", "1/10", "2-3", "1", "1.0", "01", "01.00", "asfdkjlæ" ),
                            s2    = c("(10)", "(12)", "(234)", "(00)", "(01)", "(098)", "(01)", "(01.)", "(001.0)", "()" )) -> df 

rle_man <- rle(df$manufacturer)

css_matrix <- matrix( data = "mso-number-format:\"\\@\"", nrow = nrow(df), ncol = ncol(df))
css_matrix[,1] <- "padding-left: 0.4cm;mso-number-format:\"\\@\""
css_matrix[,2:10] <- "padding-left: 1cm;mso-number-format:\"\\@\""
css_matrix[,5] <- "padding-left: 2cm;mso-number-format:\"\\@\""

htmlTable( x = df,  
           rgroup   = rle_man$values, n.rgroup = rle_man$lengths, 
           rnames   = FALSE, align = c("l", "r" ), 
           cgroup   =  rbind(  c("", "Un peu de texte va ici. Il est long et ne se coupe pas", "Un autre texte va ici", NA),
                               c( "", "Type de machine(marque)", "Spécification de la machine", "Autres variables")),
           n.cgroup = rbind(   c(1,8,2, NA),
                               c(1, 3, 5, 2)), 
           css.cell = css_matrix )            -> html_out

temp_file <- tempfile( pattern = "table", fileext = ".html" )
readr::write_file( x = html_out, path = temp_file)
utils::browseURL( temp_file)

Ce fichier HTML peut être glissé-déposé dans Excel avec toutes les cellules interprétées comme du texte. Notez que seul le fait de glisser-déposer le fichier html dans Excel fonctionne, il ne suffit pas d'ouvrir le tableau dans un navigateur et de le copier-coller dans Excel.

La seule chose qui manque à cette méthode est les lignes horizontales, mais je peux m'en accommoder.

Voici le VBA avec le même effet que le glisser-déposer :

Sub importhtml()
'
' importhtml Macro
'

'
With ActiveSheet.QueryTables.Add(Connection:= _
                                 "URL;file:///C:/Users/INSERTUSERNAME/Desktop/table18b85c0a20f3html.HTML", Destination:=Range("$a$1"))

.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = False
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlEntirePage
.WebFormatting = xlWebFormattingAll
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = True
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With

End Sub

Answer 1

Pour une solution côté client

Exécutez ce code après le premier bloc de code, il réécrit les deux dernières colonnes.

Sub Test2()
    '* outils références ->
    '*   Bibliothèque d'objets HTML Microsoft

    Dim oHtml4 As MSHTML.IHTMLDocument4
    Set oHtml4 = New MSHTML.HTMLDocument

    Dim oHtml As MSHTML.HTMLDocument
    Set oHtml = Nothing

    '* IHTMLDocument4.createDocumentFromUrl
    '* MSDN - Méthode createDocumentFromUrl de IHTMLDocument4 - https://msdn.microsoft.com/en-us/library/aa752523(v=vs.85).aspx
    Set oHtml = oHtml4.createDocumentFromUrl("https://rasmusrhl.github.io/stuff/", "")
    While oHtml.readyState <> "complete"
        DoEvents  '* ne commentez pas cela, c'est nécessaire pour interrompre le code en cas de boucle infinie
    Wend
    Debug.Assert oHtml.readyState = "complete"

    Dim oTRs As MSHTML.IHTMLDOMChildrenCollection
    Set oTRs = oHtml.querySelectorAll("TR")
    Debug.Assert oTRs.Length = 17

    Dim lRowNum As Long
    For lRowNum = 3 To oTRs.Length - 1

        Dim oTRLoop As MSHTML.HTMLTableRow
        Set oTRLoop = oTRs.Item(lRowNum)
        If oTRLoop.ChildNodes.Length > 1 Then

            Debug.Assert oTRLoop.ChildNodes.Length = 14

            Dim oSecondToLastColumn As MSHTML.HTMLTableCell
            Set oSecondToLastColumn = oTRLoop.ChildNodes.Item(12)

            ActiveSheet.Cells(lRowNum + 2, 13).Value2 = "'" & oSecondToLastColumn.innerText

            Dim oLastColumn As MSHTML.HTMLTableCell
            Set oLastColumn = oTRLoop.ChildNodes.Item(13)

            ActiveSheet.Cells(lRowNum + 2, 14).Value2 = "'" & oLastColumn.innerText

        End If
        'Stop

    Next lRowNum

    ActiveSheet.Columns("M:M").EntireColumn.AutoFit
    ActiveSheet.Columns("N:N").EntireColumn.AutoFit

End Sub

Pour une solution côté serveur

Maintenant que nous savons que vous contrôlez le script source et qu'il est en R, on peut modifier le script R pour styliser les dernières colonnes avec mso-number-format:'\@'. Voici un exemple de script R qui y parvient, on construit une matrice CSS des mêmes dimensions que les données et on passe la matrice CSS en paramètre dans htmlTable. Je n'ai pas modifié votre source R, je donne ici une simple illustration pour que vous puissiez l'interpréter.

A=matrix(c("(2)","(4)","(3)","(1)","(5)","(7)"),nrow=2,ncol=3,byrow=TRUE)
css_matrix <- matrix(data="",nrow=2,ncol=3)
css_matrix[,3] <- "mso-number-format:\"\\@\""
htmlTable(x=A,css.cell=css_matrix)

En ouvrant dans Excel, j'obtiens ceci

Robin Mackenzie ajoute

vous pourriez mentionner dans votre solution côté serveur que l'OP doit simplement ajouter css_matrix[,10:11] <- "mso-number-format:\"\@\"" à leur code R existant (après la dernière ligne css_matrix...) et cela implémentera votre solution pour leur problème spécifique

Merci Robin

Answer 2

Pour obtenir les données tabulaires (en conservant le format tel quel) de cette page, vous pouvez essayer comme suit :

 Sub Fetch_Data()
    Dim http As New XMLHTTP60, html As New HTMLDocument
    Dim posts As Object, post As Object, elem As Object
    Dim row As Long, col As Long

    With http
        .Open "GET", "https://rasmusrhl.github.io/stuff/", False
        .send
        html.body.innerHTML = .responseText
    End With

    Set posts = html.getElementsByClassName("gmisc_table")(0)

    For Each post In posts.Rows
        For Each elem In post.Cells
            col = col + 1: Cells(row + 1, col).NumberFormat = "@": Cells(row + 1, col) = elem.innerText
        Next elem
        col = 0
        row = row + 1
    Next post
End Sub

Référence à ajouter à la bibliothèque :

1. Bibliothèque d'objets Microsoft HTML
2. Microsoft XML, v6.0  'ou quelle que soit la version que vous avez

Voici à quoi ressemble cette partie une fois analysée.

Answer 3

Cela fonctionne avec un fichier temporaire.

Ce que cela fait : Télécharge des données localement. Puis, remplace les "(" par un "\". Ensuite, importe les données. Formate les données en tant que texte (pour s'assurer que nous pouvons les modifier à nouveau sans erreur). Puis, modifie le texte. Cela ne peut pas être fait avec Range.Replace car cela reformatera le contenu de la cellule.

' Variables locales
Public FileName As String ' Chemin du fichier temporaire
Public FileUrl As String ' Chemin du fichier temporaire formaté en URL
Public DownloadUrl As String ' Où nous allons télécharger depuis

' Les déclarations doivent être au début
Private Declare Function GetTempPath Lib "kernel32" _
  Alias "GetTempPathA" _
  (ByVal nBufferLength As Long, _
  ByVal lpBuffer As String) As Long
Private Declare Function GetTempFileName Lib "kernel32" _
  Alias "GetTempFileNameA" _
  (ByVal lpszPath As String, _
  ByVal lpPrefixString As String, _
  ByVal wUnique As Long, _
  ByVal lpTempFileName As String) As Long

' Chargement du contenu HTML sans bug
Sub ImportHtml()

    ' Définir notre URL de téléchargement
    DownloadUrl = "https://rasmusrhl.github.io/stuff"

    ' Définit le chemin du fichier temporaire
    SetFilePath

    ' Télécharge le fichier
    DownloadFile

    ' Remplace les "(" dans le fichier par "\(", nous le remettrons plus tard
    ' Cela garantit que le formatage du contenu n'est pas modifié!!!
    ReplaceStringInFile

    ' Notre table de requête provient maintenant du fichier local, au lieu de
    Dim s As QueryTable
    Set s = ActiveSheet.QueryTables.Add(Connection:=("FINDER;file://" + FileUrl), Destination:=Range("$A$1"))

    With s

        .Name = "stuff"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = False
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .WebSelectionType = xlEntirePage
        .WebFormatting = xlWebFormattingAll
        .WebPreFormattedTextToColumns = True
        .WebConsecutiveDelimitersAsOne = True
        .WebSingleBlockTextImport = False
        .WebDisableDateRecognition = True
        .WebDisableRedirections = False
        .Refresh BackgroundQuery:=False

        ' Définit le formatage pour que lorsque nous changeons le texte, les données ne changent pas
        .ResultRange.NumberFormat = "@"

        ' Boucle à travers les cellules dans la plage
        ' Si vous faites un remplacement Excel, il changera le format de cellule
        Const myStr As String = "\(", myReplace As String = "("
        For Each c In .ResultRange.Cells
            Do While c.Value Like "*" & myStr & "*"
                c.Characters(InStr(1, c.Value, myStr), Len(myStr)).Text = myReplace
            Loop
        Next

    End With
End Sub

' Cette fonction remplace les "(" dans le fichier par "\("
Sub ReplaceStringInFile()

    Dim sBuf As String
    Dim sTemp As String
    Dim iFileNum As Integer
    Dim sFileName As String

    ' Éditer si nécessaire
    sFileName = FileName

    iFileNum = FreeFile
    Open sFileName For Input As iFileNum

    Do Until EOF(iFileNum)
        Line Input #iFileNum, sBuf
        sTemp = sTemp & sBuf & vbCrLf
    Loop
    Close iFileNum

    sTemp = Replace(sTemp, "(", "\(")

    iFileNum = FreeFile
    Open sFileName For Output As iFileNum
    Print #iFileNum, sTemp
    Close iFileNum

End Sub

' Cette fonction définit les chemins des fichiers car nous avons besoin d'un fichier temporaire
Function SetFilePath()

    If FileName = "" Then
        FileName = GetTempHtmlName
        FileUrl = Replace(FileName, "\", "/")
    End If

End Function

' Cette sous-routine télécharge le fichier depuis l'URL spécifiée
' Le téléchargement est nécessaire car nous allons modifier le fichier
Sub DownloadFile()

    Dim myURL As String
    myURL = "https://rasmusrhl.github.io/stuff"

    Dim WinHttpReq As Object
    Set WinHttpReq = CreateObject("Microsoft.XMLHTTP")
    WinHttpReq.Open "GET", DownloadUrl, False, "username", "password"
    WinHttpReq.send

    myURL = WinHttpReq.responseBody
    If WinHttpReq.Status = 200 Then
        Set oStream = CreateObject("ADODB.Stream")
        oStream.Open
        oStream.Type = 1
        oStream.Write WinHttpReq.responseBody
        oStream.SaveToFile FileName, 2 ' 1 = pas d'écrasement, 2 = écrasement
        oStream.Close
    End If

End Sub

'''''''''''''''''''''''''''''
' CE BLOC DE CODE OBTIENT UN CHEMIN DE FICHIER TEMPORAIRE EN UTILISANT LA FONCTION GetTempHtmlName
'''''''''''''''''''''''''''''

Public Function GetTempHtmlName( _
  Optional sPrefix As String = "VBA", _
  Optional sExtensao As String = "") As String
  Dim sTmpPath As String * 512
  Dim sTmpName As String * 576
  Dim nRet As Long
  Dim F As String
  nRet = GetTempPath(512, sTmpPath)
  If (nRet > 0 And nRet < 512) Then
    nRet = GetTempFileName(sTmpPath, sPrefix, 0, sTmpName)
    If nRet <> 0 Then F = Left$(sTmpName, InStr(sTmpName, vbNullChar) - 1)
    If sExtensao > "" Then
      Kill F
      If Right(F, 4) = ".tmp" Then F = Left(F, Len(F) - 4)
      F = F & sExtensao
    End If
    F = Replace(F, ".tmp", ".html")
    GetTempHtmlName = F
  End If
End Function

'''''''''''''''''''''''''''''
' Fin - GetTempHtmlName
'''''''''''''''''''''''''''''

Answer 4

Vous pouvez essayer ceci pour voir si vous obtenez la sortie désirée...

Sub GetWebData()
Dim IE As Object
Dim doc As Object
Dim TRs As Object
Dim TR As Object
Dim Cell As Object
Dim r As Long, c As Long

Application.ScreenUpdating = False

Set IE = CreateObject("InternetExplorer.Application")
IE.Visible = False
IE.navigate "https://rasmusrhl.github.io/stuff/"
Do While IE.Busy Or IE.readyState <> 4
    DoEvents
Loop
Set doc = IE.document

Set TRs = doc.getElementsByTagName("tr")
Cells.Clear

For Each TR In TRs
    r = r + 1
    For Each Cell In TR.Children
        c = c + 1
        Cells(r, c).NumberFormat = "@"
        Cells(r, c) = Cell.innerText
    Next Cell
    c = 0
Next TR
IE.Quit
Columns.AutoFit
Application.ScreenUpdating = True
End Sub

Solution 2:

Pour que cela fonctionne, vous devez ajouter les deux références suivantes en allant dans Outils (dans l'éditeur VBA) --> Références, puis trouvez les deux références mentionnées ci-dessous et cochez les cases à côté d'elles, puis cliquez sur OK.

1) Microsoft XML, v6.0 (trouvez la version maximale disponible)

2) Bibliothèque d'objets HTML Microsoft

Sub GetWebData2()
Dim XMLpage As New MSXML2.XMLHTTP60
Dim doc As New MSHTML.HTMLDocument
Dim TRs As IHTMLElementCollection
Dim TR As IHTMLElement
Dim Cell As IHTMLElement
Dim r As Long, c As Long

Application.ScreenUpdating = False

Set XMLpage = CreateObject("MSXML2.XMLHTTP")

XMLpage.Open "GET", "https://rasmusrhl.github.io/stuff/", False
XMLpage.send
doc.body.innerhtml = XMLpage.responsetext
Set TRs = doc.getElementsByTagName("tr")
Set TRs = doc.getElementsByTagName("tr")
Cells.Clear

For Each TR In TRs
    r = r + 1
    For Each Cell In TR.Children
        c = c + 1
        Cells(r, c).NumberFormat = "@"
        Cells(r, c) = Cell.innerText
    Next Cell
    c = 0
Next TR
Columns.AutoFit
Application.ScreenUpdating = True
End Sub

Answer 5

    td {mso-number-format: '\@';}

En mettant la définition de style globale ci-dessus pour les cellules (

s) sur la sortie que vous générez en utilisant R ou en réécrivant le document côté client comme ci-dessous fonctionne tout simplement.

Sub importhtml()
    '*********** Processus de réécriture du document HTML ***************
    Const TableUrl = "https://rasmusrhl.github.io/stuff"

    Const adTypeBinary = 1, adSaveCreateOverWrite = 2, TemporaryFolder = 2
    Dim tempFilePath, binData() As Byte

    With CreateObject("Scripting.FileSystemObject")
        tempFilePath = .BuildPath(.GetSpecialFolder(TemporaryFolder), .GetTempName() & ".html")
    End With

    'télécharger le document HTML
    With CreateObject("MSXML2.ServerXMLHTTP")
        .Open "GET", TableUrl, False
        .Send
        If .Status <> 200 Then Err.Raise 3, "importhtml", "200 expected"
        binData = .ResponseBody
    End With

    With CreateObject("Adodb.Stream")
        .Charset = "x-ansi"
        .Open
        .WriteText "td {mso-number-format:'\@';}"
        .Position = 0 'déplacer au début
        .Type = adTypeBinary 'changer le type de flux
        .Position = .Size 'déplacer à la fin
        .Write binData 'ajouter les données binaires à la fin du flux
        .SaveToFile tempFilePath, adSaveCreateOverWrite 'enregistrer le fichier temporaire
        .Close
    End With
    '*********** Processus de réécriture du document HTML ***************

    With ActiveSheet.QueryTables.Add(Connection:= _
        "URL;" & tempFilePath, Destination:=Range("$A$1"))
        'charger le document HTML à partir de la copie locale réécrite

        .Name = "stuff"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = False
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .WebSelectionType = xlEntirePage
        .WebFormatting = xlWebFormattingAll
        .WebPreFormattedTextToColumns = True
        .WebConsecutiveDelimitersAsOne = True
        .WebSingleBlockTextImport = False
        .WebDisableDateRecognition = True
        .WebDisableRedirections = False
        .Refresh BackgroundQuery:=False

    End With

    Kill tempFilePath
End Sub