protect formular1c1 for code html r excel vba excel-vba

formular1c1 - Convierta la tabla HTML a Excel usando VBA



vba code for excel (9)

Convertir tabla HTML a Excel

El siguiente código recupera la tabla HTML en https://rasmusrhl.github.io/stuff y la convierte a formato Excel.

El problema es ese:

  • Los números entre paréntesis se convierten a números negativos
  • Los números son redondeados o truncados

Solución

Gracias a todos por sus grandes contribuciones. Los variados torres me ayudaron a entender que, para mis propósitos, una solución alternativa era la mejor solución: dado que genero las tablas HTML yo mismo, puedo controlar el CSS de cada celda. Existen códigos CSS que le indican a Excel cómo interpretar los contenidos de la celda: http://cosicimiento.blogspot.dk/2008/11/styling-excel-cells-with-mso-number.html , también explicado en esta pregunta: Formato de la celda de la tabla HTML para que los formatos de Excel como texto?

En mi caso, el CSS debería ser texto, que es mso-number-format:/"//@/" . Está integrado en el código R a continuación:

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("", "Some text goes here. It is long and does not break", "Other text goes here", NA), c( "", "Machine type<br>(make)", "Specification of machine", "Other 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)

Ese archivo HTML se puede arrastrar y soltar en Excel con todas las celdas interpretadas como texto. Tenga en cuenta que solo arrastrar y soltar el archivo html en excel funciona, no funciona abrir la tabla en un navegador y copiarla y pegarla en Excel.

Lo único que falta de este método son las líneas horizontales, pero puedo vivir con eso.

Debajo está VBA con el mismo efecto que arrastrar y soltar:

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


Con la URL https://rasmusrhl.github.io/stuff , es por suerte que Excel simplemente puede abrirlo directamente y guardarlo como .xlsx (¿cómo es que nadie prueba esto antes del tedioso proceso). Si la apertura directa falla, todos los demás métodos aquí son una gran opción.

Option Explicit Sub OpenWebFile() Const URL As String = "https://rasmusrhl.github.io/stuff" Dim oWB As Workbook On Error Resume Next Set oWB = Workbooks.Open(Filename:=URL, ReadOnly:=True) If oWB Is Nothing Then MsgBox "Cannot open the url " & URL, vbExclamation + vbOKOnly, "ERR " & Err.Number & ":" & Err.Description Err.Clear Else '' Change to your desired path and filename oWB.SaveAs Filename:="C:/Test/stuff.xlsx", FileFormat:=xlOpenXMLWorkbook Set oWB = Nothing End If End Sub


En función de la documentación de Microsoft MSDN Library: Propiedad de WebFormatting , puede probar el siguiente cambio en su código:

.WebFormatting = xlWebFormattingNone

Esto puede permitir que los datos se copien sin ningún formato de número; luego puede establecer su propio formato numérico para esas celdas (usando MSDN: propiedad Excel Excel VBA NumberFormat )

Una solución similar debería resolver el problema con números truncados o redondeados: establezca los puntos decimales para las celdas afectadas en su rango objetivo ...


Esto funciona con un archivo temporal.

Qué hace: descarga datos localmente. Luego, reemplaza el "(" con un "/". Luego, importa los datos. Formatea los datos como texto (para asegurar que podamos volver a cambiarlos sin error). Luego, cambia el texto. Esto no se puede hacer con Range.Replace porque eso formateará el contenido de la celda.

'' Local Variables Public FileName As String '' Temp File Path Public FileUrl As String '' Url Formatted Temp File Path Public DownloadUrl As String '' Where We''re Going to Download From '' Declares Have to Be At Top 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 '' Loads the HTML Content Without Bug Sub ImportHtml() '' Set Our Download URL DownloadUrl = "https://rasmusrhl.github.io/stuff" '' Sets the Temporary File Path SetFilePath '' Downloads the File DownloadFile '' Replaces the "(" in the File With "/(", We Will Later Put it Back '' This Ensures Formatting of Content Isn''t Modified!!! ReplaceStringInFile '' Our Query Table is Now Coming From the Local File, Instead 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 '' Sets Formatting So When We Change Text the Data Doesn''t Change .ResultRange.NumberFormat = "@" '' Loop Through Cells in Range '' If You Do Excel Replace, Instead It Will Change Cell Format 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 '' This function replaces the "(" in the file with "/(" Sub ReplaceStringInFile() Dim sBuf As String Dim sTemp As String Dim iFileNum As Integer Dim sFileName As String '' Edit as needed 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 '' This function sets file paths because we need a temp file Function SetFilePath() If FileName = "" Then FileName = GetTempHtmlName FileUrl = Replace(FileName, "/", "/") End If End Function '' This subroutine downloads the file from the specified URL '' The download is necessary because we will be editing the file 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 = no overwrite, 2 = overwrite oStream.Close End If End Sub '''''''''''''''''''''''''''''''''''''''''''''''''''''''''' '' THIS BLOCK OF CODE GETS A TEMPORARY FILE PATH USING THE GetTempHtmlName Function '''''''''''''''''''''''''''''''''''''''''''''''''''''''''' 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 '''''''''''''''''''''''''''''''''''''''''''''''''''''''''' '' End - GetTempHtmlName ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''


Intenta esto, para importar los datos como una tabla:

Sub ImportDataAsTable() ActiveWorkbook.Queries.Add Name:="Table 0", Formula:= _ "let" & Chr(13) & "" & Chr(10) & " Source = Web.Page(Web.Contents(""https://rasmusrhl.github.io/stuff/""))," & Chr(13) & "" & Chr(10) & " Data0 = Source{0}[Data]," & Chr(13) & "" & Chr(10) & " #""Changed Type"" = Table.TransformColumnTypes(Data0,{{""tailnum"", type text}, {"""", type text}, {""Some text goes here. It is long and does not break Machine type (make) year"", type text}, {""Some text goes here. It is long and does not break Mach" & _ "ine type (make) type"", type text}, {""Some text goes here. It is long and does not break Machine type (make) manufacturer"", type text}, {""Some text goes here. It is long and does not break"", type text}, {""Some text goes here. It is long and does not break Specification of machine model"", type text}, {""Some text goes here. It is long and does not break Specifi" & _ "cation of machine engines"", type text}, {""Some text goes here. It is long and does not break Specification of machine seats"", type text}, {""Some text goes here. It is long and does not break Specification of machine speed"", type text}, {""Some text goes here. It is long and does not break Specification of machine engine"", type text}, {""2"", type text}, {""Oth" & _ "er text goes here Other variables s1"", type text}, {""Other text goes here Other variables s2"", type text}})" & Chr(13) & "" & Chr(10) & "in" & Chr(13) & "" & Chr(10) & " #""Changed Type""" ActiveWorkbook.Worksheets.Add With ActiveSheet.ListObjects.Add(SourceType:=0, Source:= _ "OLEDB;Provider=Microsoft.Mashup.OleDb.1;Data Source=$Workbook$;Location=""Table 0"";Extended Properties=""""" _ , Destination:=Range("$A$1")).QueryTable .CommandType = xlCmdSql .CommandText = Array("SELECT * FROM [Table 0]") .RowNumbers = False .FillAdjacentFormulas = False .PreserveFormatting = True .RefreshOnFileOpen = False .BackgroundQuery = True .RefreshStyle = xlInsertDeleteCells .SavePassword = False .SaveData = True .AdjustColumnWidth = True .RefreshPeriod = 0 .PreserveColumnInfo = True .ListObject.DisplayName = "Table_0" .Refresh BackgroundQuery:=False End With End Sub


Para obtener los datos tabulares (manteniendo el formato tal como está) desde esa página, puede intentar lo siguiente:

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

Referencia para agregar a la biblioteca:

1. Microsoft HTML Object Library 2. Microsoft XML, v6.0 ''or whatever version you have

Así es como se ve esa porción cuando se analiza.


Procesar el HTML y luego copiarlo y pegarlo en Excel lo hará

Estos son los pasos que utilicé:

  • CreateObject("MSXML2.XMLHTTP") : obtener la respuesta de la CreateObject("MSXML2.XMLHTTP")
  • CreateObject("HTMLFile") : crea un documento HTML a partir de responseText
  • Reemplace gris con negro para oscurecer los bordes
  • Prefija las columnas s1 y s2 con @ para conservar el formato
  • Copie el HTML al portapapeles de Windows
    • Nota: El HTML debe estar encerrado en etiquetas HTML y Body para pegar correctamente
  • Configurar la hoja de trabajo de destino
  • Pegue el HTML en la Hoja de trabajo
  • Reemplace el signo @ con ''
    • Nota: Esto preserva el formato almacenando los datos como texto
  • Finaliza el formateo de la hoja de trabajo

Sub LoadTable() Const URL = "https://rasmusrhl.github.io/stuff/" Dim x As Long Dim doc As Object, tbl As Object, rw As Object With CreateObject("MSXML2.XMLHTTP") .Open "GET", URL, False .send If .readyState = 4 And .Status = 200 Then Set doc = CreateObject("HTMLFile") doc.body.innerHTML = .responseText doc.body.innerHTML = Replace(doc.body.innerHTML, "grey", "black") Set tbl = doc.getElementsByTagName("TABLE")(0) For x = 0 To tbl.Rows.Length - 1 Set rw = tbl.Rows(x) If rw.Cells.Length = 14 Then ''If InStr(rw.Cells(12).innerText, "-") Or InStr(rw.Cells(12).innerText, "/") Then rw.Cells(12).innerText = "@" & rw.Cells(12).innerText rw.Cells(13).innerText = "@" & rw.Cells(13).innerText End If Next With CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}") .SetText "<html><body>" & doc.body.innerHTML & "</body></html>" .PutInClipboard End With With Worksheets("Sheet1") .Cells.Clear .Range("A1").PasteSpecial .Cells.Interior.Color = vbWhite .Cells.WrapText = False .Columns.AutoFit .Columns("M:N").Replace What:="@", Replacement:="''" End With Else MsgBox "URL: " & vbCrLf & "Ready state: " & .readyState & vbCrLf & "HTTP request status: " & .Status, vbInformation, "URL Not Responding" End If End With End Sub


Puede probar esto para ver si obtiene el resultado deseado ...

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

Solución 2:

Para que funcione, debe agregar las dos referencias siguientes yendo a Herramientas (en el Editor de VBA) -> Referencias y luego encontrar las dos referencias mencionadas a continuación y marcar las casillas de verificación para ellas y hacer clic en Aceptar.

1) Microsoft XML, v6.0 (encuentre la versión máxima disponible)

2) Biblioteca de objetos HTML de 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


Para una solución del lado del cliente

Entonces ejecute este código después del primer bloque de código, reescribe las dos columnas finales.

Sub Test2() ''* tools references -> ''* Microsoft HTML Object Library Dim oHtml4 As MSHTML.IHTMLDocument4 Set oHtml4 = New MSHTML.HTMLDocument Dim oHtml As MSHTML.HTMLDocument Set oHtml = Nothing ''* IHTMLDocument4.createDocumentFromUrl ''* MSDN - IHTMLDocument4 createDocumentFromUrl method - 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 ''* do not comment this out it is required to break into the code if in infinite loop 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

Para una solución de servidor

Ahora que sabemos que usted controla el script fuente y que está en R, entonces puede cambiar el guión R para darle un estilo a las columnas finales con mso-number-format: ''/ @''. Aquí hay un ejemplo de script R que lo consigue, uno crea una matriz CSS con las mismas dimensiones que los datos y pasa la matriz CSS como parámetro a htmlTable . No he alterado tu fuente R, sino que doy aquí una ilustración simple para que interpretes.

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)

Al abrir en Excel obtengo esto

Robin Mackenzie agrega

puede mencionar en su solución del lado del servidor que OP solo necesita agregar css_matrix [, 10: 11] <- "mso-number-format: /" / @ / "" a su código R existente (después de la última css_matrix ... .line) e implementará su solución para su problema específico

Gracias Robin


<style type=text/css> td {mso-number-format: ''/@'';} </style> <table ...

Poner la definición de estilo global anterior para las celdas ( <td> s) en la salida que generas usando R o reescribiendo el documento en el lado del cliente de la siguiente manera simplemente funciona.

Sub importhtml() ''*********** HTML document rewrite process *************** 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 ''download HTML document 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 "<style type=text/css>td {mso-number-format:''/@'';}</style>" .Position = 0 ''move to start .Type = adTypeBinary ''change stream type .Position = .Size ''move to end .Write binData ''append binary data end of stream .SaveToFile tempFilePath, adSaveCreateOverWrite ''save temporary file .Close End With ''*********** HTML document rewrite process *************** With ActiveSheet.QueryTables.Add(Connection:= _ "URL;" & tempFilePath, Destination:=Range("$A$1")) ''load HTML document from rewritten local copy .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