How to modify VBA code for Excel to use with an Access table?

Question

I got this code from a competent user, not sure if he wants to be named. The code searches the HTML content for innerText of certain tags and transfers them to an Excel table, well sorted under the headers, structured as pivot.

Public Sub GetDataFromURL()
    Const URL = "URL"
    Dim html As MSHTML.HTMLDocument, xhr As Object

    Set html = New MSHTML.HTMLDocument
    Set xhr = CreateObject("MSXML2.ServerXMLHTTP.6.0")

    With xhr
        .Open "POST", URL, False
        .setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
        .send "...parameters..."
        html.body.innerHTML = .responseText
    End With

    Dim table As MSHTML.HTMLTable, r As Long, c As Long, headers(), row As MSHTML.HTMLTableRow
    Dim results() As Variant, html2 As MSHTML.HTMLDocument

    headers = Array("HDR01", "HDR02", "HDR03", "HDR04")

    ReDim results(1 To 100, 1 To UBound(headers) + 1)

    Set table = html.querySelector("table")
    Set html2 = New MSHTML.HTMLDocument

    Dim lastRow As Boolean

    For Each row In table.Rows
        lastRow = False
        Dim header As String

        html2.body.innerHTML = row.innerHTML
        header = Trim$(row.Children(0).innerText)

        If header = "HDR01" Then
            r = r + 1
            Dim dict As Scripting.Dictionary: Set dict = GetBlankDictionary(headers)
            On Error Resume Next
            dict("HDR02") = Replace$(html2.querySelector("a").href, "about:", "https://URL")
            On Error GoTo 0
        End If

        If dict.Exists(header) Then dict(header) = Trim$(row.Children(1).innerText)

        If (header = vbNullString And html2.querySelectorAll("a").Length > 0) Then
            dict("HDR03") = Replace$(html2.querySelector("a").href, "about:blank", "URL")
            lastRow = True
        ElseIf header = "HDR04" Then
            If row.NextSibling.NodeType = 1 Then lastRow = True
        End If

        If lastRow Then
            populateArrayFromDict dict, results, r
        End If
    Next

    results = Application.Transpose(results)
    ReDim Preserve results(1 To UBound(headers) + 1, 1 To r)
    results = Application.Transpose(results)
    
    Dim re As Object
    
    Set re = CreateObject("VBScript.RegExp")
    
    With re
        .Global = False
        .MultiLine = False
        .IgnoreCase = True
        .Pattern = "\s([0-9.]+)\sm²"
    End With

    Dim ie As SHDocVw.InternetExplorer
    
    Set ie = New SHDocVw.InternetExplorer
    
    With ie
        .Visible = True
        
        For r = LBound(results, 1) To UBound(results, 1)
            
            If results(r, 7) <> vbNullString Then
                
                .Navigate2 results(r, 7), headers:="Referer: " & URL
                
                While .Busy Or .readyState <> READYSTATE_COMPLETE: DoEvents: Wend
 
                'On Error Resume Next
                results(r, 8) = re.Execute(.document.querySelector("#anz").innerHTML)(0).Submatches(0)
                'On Error GoTo 0
   
            End If
            
        Next
        
        .Quit
        
    End With
    
    With ActiveSheet
        .Cells(1, 1).Resize(1, UBound(headers) + 1) = headers
        .Cells(2, 1).Resize(UBound(results, 1), UBound(results, 2)) = results
    End With

End Sub

It works perfectly in Excel, but I need it for an Access-table. My Aceess-table named tblTab01 contains all the fields that are present in the code in the headers = array("..."), and I have disabled the following lines in the code:

results = Application.Transpose(results)

and

ActiveSheet.Cells(1, 1).Resize(1, UBound(headers) + 1) = headers

Instead, I added the following lines:

Dim db As DAO.Database
Dim strInsert
Set db = CurrentDb
strInsert = "INSERT INTO tblTab01 VALUES (results);"
db.Execute strInsert

But I only get all possible errors!

How would the code need to be modified for use with the Access table? THX

Answer 1

This produces same output as the Excel code. I attempted a solution that eliminated looping array but this version is actually faster.

Had to use Excel WorksheetFunction to make the Transpose method work. Make sure Excel library is selected in References.

    results = Excel.WorksheetFunction.Transpose(results)
    ReDim Preserve results(1 To UBound(headers) + 1, 1 To r)
    results = Excel.WorksheetFunction.Transpose(results)

Uncomment the On Error lines:

On Error Resume Next
results(r, 8) = re.Execute(.document.querySelector("#anz").innerHTML)(0).Submatches(0)
On Error GoTo 0

Then instead of the With ActiveSheet block, loop through array.

    Dim db As DAO.Database
    Dim rs As DAO.Recordset
    CurrentDb.Execute "DELETE * FROM tblNetzPortDwnLd"
    Set db = CurrentDb
    Set rs = db.OpenRecordset("tblNetzPortDwnLd", dbOpenDynaset)
    For r = LBound(results, 1) To UBound(results, 1)
        With rs
            .AddNew
            .Fields("zpID") = r
            .Fields("zpAktenzeichen") = results(r, 1)
            .Fields("zpAmtsgericht") = results(r, 2)
            .Fields("zpObjekt") = results(r, 3)
            .Fields("zpVerkehrswert") = results(r, 4)
            .Fields("zpTermin") = results(r, 5)
            .Fields("zpPdfLink") = results(r, 6)
            .Fields("zpAdditLink") = results(r, 7)
            .Fields("zpm2") = results(r, 8)
            .Update
        End With
    Next

All fields in table are text type, per our chat discussion.