Access all li elements between two specific heading elements

Question

Problem Description:

I am looking for a way to access the li-elements between two specific heading-tags only (e.g.from 2nd h3 to 3rd h3 or from 3rd h3 to next h4) in order to create a table of historical events listed on https://de.wikipedia.org/wiki/1._Januar structured along the criteria mentioned in the headings. A major problem (for me ...) is that - other than the h1-heading - the subtitles of the lower levels have no className or id.

Sample of HTML:


  [...]
  
  
    153 v. Chr.: Die Konsuln der römischen Republik beginnen ihre Amtszeit erstmals
      am 1. Januar statt am 1. März; daher ist der 1. Januar heute der Jahresanfang.
    045 v. Chr.: Caesars Reform des römischen Kalenders endet. Dieser wird ab 2. Januar 709 a. u. c. durch den julianischen Kalender      ersetzt.
    032 v. Chr.: Oktavian lässt sich vom Senat zum
      „Führer Italiens“ (dux Italiae) ausrufen. Er erklärt Kleopatra und damit de facto      auch Marcus Antonius den Krieg.
  
  [...]
  
  Inkrafttreten von Gesetzen und Staatsverträgen[
    Bearbeiten | 
    Quelltext bearbeiten]
  
  Der 1. Januar wird oft für das Inkrafttreten von Gesetzen und Staatsverträgen verwendet. Das gilt unter anderem für:
  
  
    1812: das Allgemeine bürgerliche Gesetzbuch (ABGB) in den habsburgischen Erblanden.
  
  [...]
  
  Folgende Staaten erhalten am 1. Januar ihre Unabhängigkeit:
  
  
    [...]
  
  Wirtschaft[Bearbeiten
     | Quelltext bearbeiten]
  
  Wichtige Ereignisse in der Weltwirtschaft[Bearbeiten | Quelltext bearbeiten
    ]
    
  
  
    1780: In Preßburg erscheint die erste ungarische Zeitung Magyar hírmondó („Ungarischer Kurier“).

So far, I only managed to access all the li-elements (more than 1000!) that are not part of the table of contents with the following code:

Experimental Code Example:


Sub HistoricalEvents_Test()
    Dim http   As Object, html As New MSHTML.HTMLDocument
    Dim oLiList As MSHTML.IHTMLDOMChildrenCollection
    Dim data   As String
    Dim r      As Integer
    Dim oWord  As Object, oWordDoc As Object
    Dim wordApp As New Word.Application
    Dim iFirstRow As Integer, iLastRow As Integer

    Set http = CreateObject("MSXML2.XMLHTTP")
    http.Open "GET", "https://de.wikipedia.org/wiki/1._Januar", False
    http.send
    html.body.innerHTML = http.responseText
   
      
    Dim lLiResultList As Long
    Dim lLiResultLoop As Long
    
    Set oLiList = html.querySelectorAll("#toc ~ ul li")
      
    For lLiResultLoop = 0 To oLiList.Length - 1
        Dim oLiChild As Object
        Set oLiChild = oIlList.Item(lLilResultLoop)
            data = oLiChild.innerText   'data = data & vbCrLf & oLiChild.innerText
            Range("B" & lLiResultLoop +1).Value = data
            data = vbNullString
    Next lLiResultLoop
    
    
    Dim j      As Long
    Dim Ws As Worksheet
    Dim rngDB As Range
    Set Ws = ActiveSheet
    Set oWord = CreateObject("Word.Application")

    Set oWordDoc = oWord.Documents.Open("D:\Jahrestage Geschichte.docx")
    iFirstRow = 1             ' "Ws.Cells(1, 2).End(xlDown).Row" used to work fine but suddenly gives same as iLastRow!
    'Debug.Print iFirstRow
    iLastRow = Ws.Cells(ActiveSheet.Rows.Count, "B").End(xlUp).Row
    'Debug.Print iLastRow
    oWord.Visible = True
    
    With wordApp
        With Ws
            Set rngDB = Ws.Range(.Cells(iFirstRow, 2), .Cells(iLastRow, 2))
        End With
        rngDB.Cut
            oWord.Selection.PasteSpecial DataType:=wdPasteText
            oWord.Selection.TypeParagraph
            oWord.Selection = ""
    End With
    
    oWordDoc.Close savechanges:=True
    wordApp.Quit                                  'it doesn't :(
    
End Sub

Description of General Idea/Final Project

The final project is supposed to have a worksheet for every month, each containing a table with a row for every day of the respective month and columns for the different categories according to the (sub-)titles. The Word-output in the code is just an early-stage by-product and something I will round off only if/when the main problem can be solved.

Further Remarks

This is my first contribution on SO. I'm an absolute beginner when it comes to vba and web-scraping (or any kind of coding, scripting or programming for that matter), but I kind of got sucked into it and spent the better part of my winter holiday just to figure out the above code. I wouldn't have been able to accomplish even that poor piece of scripting without the invaluable knowledge shared with noobs like me by the cracks of SO. I've tried out various approaches but I always got stuck at some point, VBA triggering runtime errors and often Excel crashing. In particular, I wasn't able to implement the nextSibling/previousSibling methods or the nodeName selector successfully which I figure might be a promising approach to the problem. So any help or hint would be greatly appreciated!

Working Solution:

Thanks to the feedback on my question I finally managed to figure out a solution that does the job, although maybe not in the most elegant way. The only remaining problem is that strangely the li-elements of the last column are duplicated. So if anyone has a clue how to deal with that ...

Sub SliceHtmlByHeaderTypes4()

    Dim http   As Object, html As MSHTML.HTMLDocument
    Dim sh     As Worksheet
    Set sh = ThisWorkbook.ActiveSheet
    
    Set http = CreateObject("MSXML2.XMLHTTP"): Set html = New MSHTML.HTMLDocument
    http.Open "GET", "https://de.wikipedia.org/wiki/1._Januar", False
    http.send
    html.body.innerHTML = http.responseText
    
    Dim hNodeList As Object
    Dim startPos As Long, endPos As Long
    Dim s      As Integer, e As Integer
    
    Set hNodeList = html.querySelectorAll("#toc ~ h2, #toc ~ h3, #toc ~ h4")
    Debug.Print hNodeList.Length
    
    Do While s < hNodeList.Length - 1
        http.Open "GET", "https://de.wikipedia.org/wiki/1._Januar", False
        http.send
        html.body.innerHTML = http.responseText
        Set hNodeList = html.querySelectorAll("#toc ~ h2, #toc ~ h3, #toc ~ h4")
        startPos = InStr(html.body.outerHTML, hNodeList.Item(s).outerHTML)
        endPos = InStr(html.body.outerHTML, hNodeList.Item(s + 1).outerHTML)
        
        If startPos > 0 And endPos > 0 And endPos > startPos Then
            Dim strS  As String
            strS = Mid$(html.body.outerHTML, startPos, endPos - startPos + 1)
        Else
            MsgBox "Problem slicing string"
            Stop
            Exit Sub
        End If
        
        Dim liList As Object
        
        html.body.innerHTML = strS
        
        Set liList = html.getElementsByTagName("li")
        
        If liList.Length > 0 Then
            Dim i      As Integer
            Dim liText As String
            Dim lc As Integer
            Dim liRange As Range
            lc = (Cells(2, Columns.Count).End(xlToLeft).Column) + 1
            Set liRange = sh.Range(Cells(2, lc), Cells(2, lc))
            
            For i = 0 To liList.Length - 1
                On Error Resume Next
                liText = liList.Item(i).innerText
                liRange.Value = liRange.Value & liText & vbNewLine
                liText = vbNullString
            Next i
            
            strS = vbNullString
            startPos = 0
            endPos = 0
            hNodeList = ""
            i = 0
        End If
        s = s + 1
    Loop
End Sub

user_8107092 · Answer

Instead of using loops, you can just copy and paste the range at once.

Sub HistoricalEvents_Test()
    Dim http   As Object, html As New MSHTML.HTMLDocument
    Dim oUlList As MSHTML.IHTMLDOMChildrenCollection, oLiList As MSHTML.IHTMLDOMChildrenCollection
    Dim data   As String
    Dim r      As Integer
    Dim oWord  As Word.Application ' Object
    Dim oWordDoc As New Word.document ' Object
    Dim wordApp As New Word.Application
    Dim iFirstRow As Integer, iLastRow As Integer

    Set http = CreateObject("MSXML2.XMLHTTP")
    http.Open "GET", "https://de.wikipedia.org/wiki/1._Januar", False
    http.send
    html.body.innerHTML = http.responseText
    
    'this works pretty fast, but a little reformatting on the Word document (yet to be implemented) is needed:
      
    Dim lUlResultList As Long
    Dim lUlResultLoop As Long
    
    Set oUlList = html.querySelectorAll("div.mw-parser-output ul")
    
    lUlResultList = oUlList.Length
    
    For lUlResultLoop = 0 To oUlList.Length - 1
        Dim oUlChild As Object
        Set oUlChild = oUlList.Item(lUlResultLoop)
        If Not oUlChild.FirstChild.className Like "*toclevel*" Then
            data = oUlChild.innerText             'data = data & vbCrLf & oUlChild.innerText
            Range("B" & lUlResultLoop).Value = data
            data = vbNullString
        End If
    Next lUlResultLoop
    
    
    'this works as well, no reformatting needed, but pasting to Word is much slower:
    
    '    Dim lLiResultList As Long
    '    Dim lLiResultLoop As Long
    
    '    Set oLiList = html.querySelectorAll("div.mw-parser-output ul li")
    
    '    lLiResultList = oLiList.Length
    
    '    For lLiResultLoop = 0 To oLiList.Length - 1
    '        Dim oLiChild As Object
    '        Set oLiChild = oLiList.Item(lLiResultLoop)
    '        If Not oLiChild.className Like "*toclevel*" Then
    '            data = oLiChild.innerText           'data = data & vbCrLf & oLiChild.innerText
    '            Range("B" & lLiResultLoop).Value = data
    '            data = vbNullString
    '        End If
    '    Next lLiResultLoop
    
    '********************************************************************************************
    
    Dim j      As Long
    Dim Ws As Worksheet
    Dim rngDB As Range
    Set Ws = ActiveSheet
    Set oWord = CreateObject("Word.Application")

    Set oWordDoc = oWord.Documents.Open("D:\Jahrestage Geschichte.docx")
    'Set oWordDoc = oWord.Documents.Add
    iFirstRow = Ws.Cells(1, 2).End(xlDown).Row
    'Debug.Print iFirstRow
    iLastRow = Ws.Cells(ActiveSheet.Rows.Count, "B").End(xlUp).Row
    'Debug.Print iLastRow
    oWord.Visible = True
    
    With wordApp
        With Ws
            Set rngDB = Ws.Range(.Cells(iFirstRow, 2), .Cells(iLastRow, 2))
        End With
        rngDB.Cut
            oWord.Selection.PasteSpecial DataType:=wdPasteText
            oWord.Selection.TypeParagraph
'        For r = iFirstRow To iLastRow
'            Range(Cells(r, 2), Cells(r, 2)).Cut
'            oWord.Selection.PasteSpecial DataType:=wdPasteText
'            oWord.Selection.TypeParagraph
'            For j = 1 To 4
'                Dim t  As Double
'                t = Timer
'                Do Until Timer - t >= 0.4         'can't go faster or error 4605 occurs!
'                    DoEvents
'                Loop
'            Next
            oWord.Selection.TypeParagraph
            oWord.Selection = ""
        'Next r
    End With
    
    oWordDoc.Close savechanges:=True
    wordApp.Quit                                  'it doesn't :(
    
End Sub

user_6241235 · Answer

Here is an example of what I meant by narrowing down HTML to between specific headers (positional and based on header type e.g. h2 headers, first and second). Css selectors are used to ensure h2 list includes only the desired h2 elements list to then select positionally from i.e. pick the first and second items of; .outerHTML is used to ensure I slice at the start of element's html preserving tag structure for inserting back into HTML.body.innerHTML. I then query the HTMLDocument with subset html content for the li elements.

You could can hopefully see how the principal could be expanded. In order to mix header types (being cautious of css selectivity and ordering) you can use OR syntax to retrieve mixed header nodeLists at start e.g. h2 and h3 would be html.querySelectorAll("#toc ~ h2, #toc ~ h3"). Be very cautious and verify that the returned nodeList is ordered as expected when using this latter approach.

Option Explicit

Public Sub SliceHtmlByHeaderTypes()
    
    Dim http As Object, html As MSHTML.HTMLDocument
    
    Set http = CreateObject("MSXML2.XMLHTTP"): Set html = New MSHTML.HTMLDocument
    http.Open "GET", "https://de.wikipedia.org/wiki/1._Januar", False
    http.send
    html.body.innerHTML = http.responseText
    
    Dim hNodeList As Object
    
    Set hNodeList = html.querySelectorAll("#toc ~ h2")
    
    Dim startPos As Long, endPos As Long
    
    startPos = InStr(html.body.outerHTML, hNodeList.Item(0).outerHTML) ' we wanna split between 1st and 2nd i.e. indices 0 and 1
    endPos = InStr(html.body.outerHTML, hNodeList.Item(1).outerHTML)
    
    Debug.Print hNodeList.Item(0).innerText
    Debug.Print hNodeList.Item(1).innerText
    
    If startPos > 0 And endPos > 0 And endPos > startPos Then
        Dim s As String
        s = Mid$(html.body.outerHTML, startPos, endPos - startPos + 1)
    Else
       MsgBox "Problem slicing string"
       Exit Sub
    End If
    
    Dim liList As MSHTML.IHTMLElementCollection
    
    html.body.innerHTML = s  'replace html content with new spliced content
    
    Set liList = html.getElementsByTagName("li") 'then do something with list of lis
    
    Stop

End Sub

Bear in mind there are a host of wiki apis out there that may serve the content you want e.g.

https://stackoverflow.com/questions/627594/is-there-a-wikipedia-api