html - वीबीए का उपयोग कर एचटीएमएल-टेबल को एक्सेल में कनवर्ट करें




r excel (6)

आप इसे देखने का प्रयास कर सकते हैं कि क्या आपको वांछित आउटपुट मिल रहा है ...

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

समाधान 2:

इसे काम करने के लिए, आपको टूल्स (वीबीए संपादक पर) -> संदर्भों पर जाकर निम्नलिखित दो संदर्भों को जोड़ना होगा और फिर नीचे दिए गए दो संदर्भों को ढूंढें और उनके लिए चेकबॉक्स जांचें और ठीक क्लिक करें।

1) माइक्रोसॉफ्ट एक्सएमएल, v6.0 (अधिकतम संस्करण उपलब्ध है)

2) माइक्रोसॉफ्ट एचटीएमएल वस्तु पुस्तकालय

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

एक्सेल में HTML-table कनवर्ट करें

नीचे दिया गया कोड HTML-table को https://rasmusrhl.github.io/stuff पर https://rasmusrhl.github.io/stuff , और इसे एक्सेल-प्रारूप में परिवर्तित करता है।

समस्या यह है कि:

  • कोष्ठक में संख्या नकारात्मक संख्या में परिवर्तित कर रहे हैं
  • संख्या गोलाकार या छोटा कर रहे हैं

उपाय

आपके महान योगदान के लिए सभी को धन्यवाद। विभिन्न परिवेशों ने मुझे समझने में मदद की, कि मेरे उद्देश्यों के लिए एक समाधान सबसे अच्छा समाधान था: क्योंकि मैं स्वयं HTML-टेबल उत्पन्न करता हूं, मैं प्रत्येक सेल के सीएसएस को नियंत्रित कर सकता हूं। सीएसएस कोड मौजूद हैं जो एक्सेल को सेल सामग्री की व्याख्या करने का निर्देश देते हैं: http://cosicimiento.blogspot.dk/2008/11/styling-excel-cells-with-mso-number.html , इस प्रश्न में भी समझाया गया है: HTML तालिका कक्ष प्रारूपित करें ताकि Excel पाठ के रूप में स्वरूपित हो?

मेरे मामले में सीएसएस टेक्स्ट होना चाहिए, जो mso-number-format:\"\\@\" । यह नीचे आर कोड में एकीकृत है:

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)

उस HTML-फ़ाइल को खींच लिया जा सकता है और पाठ के रूप में व्याख्या की गई सभी कोशिकाओं के साथ एक्सेल में गिरा दिया जा सकता है। नोट, केवल HTML- फ़ाइल को एक्सेल कार्यों में ड्रैग-एंड-ड्रॉप करना, यह ब्राउज़र में तालिका खोलने और इसे एक्सेल में कॉपी करने के लिए काम नहीं करता है।

इस विधि से लापता एकमात्र चीज क्षैतिज रेखाएं है, लेकिन मैं इसके साथ रह सकता हूं।

नीचे खींचने और छोड़ने के समान प्रभाव के साथ वीबीए है:

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

उस पृष्ठ से टैब्यूलर डेटा (प्रारूप को रखने के रूप में) प्राप्त करने के लिए, आप नीचे की तरह प्रयास कर सकते हैं:

 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

पुस्तकालय में जोड़ने के लिए संदर्भ:

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

इस तरह यह हिस्सा पार्स किए जाने पर दिखता है।


डेटा को तालिका के रूप में आयात करने के लिए इसे आज़माएं:

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

माइक्रोसॉफ्ट एमएसडीएन लाइब्रेरी से प्रलेखन के आधार पर : वेबफॉर्मेटिंग प्रॉपर्टी आप नीचे दिए गए कोड को अपने कोड में आज़मा सकते हैं:

 .WebFormatting = xlWebFormattingNone

यह किसी भी संख्या स्वरूपण के बिना डेटा की प्रतिलिपि बनाने की अनुमति दे सकता है - फिर आप उन कक्षों के लिए अपना स्वयं का नंबर प्रारूप सेट कर सकते हैं ( एमएसडीएन का उपयोग करके : एक्सेल वीबीए संख्या फॉर्मेट संपत्ति )

एक समान समाधान को समस्या को हल करने या गोल करने के साथ समस्या को हल करना चाहिए - प्रभावित लक्ष्य के लिए दशमलव बिंदु निर्धारित करें ...


यूआरएल https://rasmusrhl.github.io/stuff , यह भाग्य से है कि एक्सेल बस इसे सीधे खोल सकता है और .xlsx के रूप में सहेज सकता है (कैसे कोई भी कठिन प्रक्रिया से पहले यह कोशिश नहीं करता है)। यदि प्रत्यक्ष खुला रहता है, तो यहां अन्य सभी विधियां बहुत अच्छी हैं!

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

एक ग्राहक पक्ष समाधान के लिए

तो कोड के पहले ब्लॉक के बाद इस कोड को चलाएं, यह अंतिम दो कॉलम को फिर से लिखता है।

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

एक सर्वर साइड समाधान के लिए

अब जब हम जानते हैं कि आप स्रोत स्क्रिप्ट को नियंत्रित करते हैं और यह आर में है तो कोई भी आर स्क्रिप्ट को अंतिम कॉलम को एमएसओ-फॉर्म-फॉर्मेट के साथ स्टाइल करने के लिए बदल सकता है: '\ @'। यहां एक नमूना आर स्क्रिप्ट है जो इसे प्राप्त करती है, एक डेटा के समान आयामों का एक सीएसएस मैट्रिक्स बनाता है और सीएसएस मैट्रिक्स को htmlTable में पैरामीटर के रूप में htmlTable । मैंने आपके आर स्रोत के साथ छेड़छाड़ नहीं की है बल्कि मैं आपको व्याख्या करने के लिए एक सरल उदाहरण देता हूं।

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)

एक्सेल में खोलना मुझे यह मिलता है

रॉबिन मैकेंज़ी कहते हैं

आप अपने सर्वर-साइड समाधान में उल्लेख कर सकते हैं कि OP को केवल css_matrix [, 10: 11] <- "mso-number-format: \" \ @ \ "" को उनके मौजूदा आर कोड में जोड़ने की आवश्यकता है (अंतिम css_matrix के बाद .. लाइन) और यह आपकी विशिष्ट समस्या के लिए आपके समाधान को लागू करेगा

धन्यवाद रॉबिन





excel-vba