如何修改 Excel 的 VBA 代码以与 Access 表一起使用？

Question

我从一位称职的用户那里得到了这个代码，不确定他是否想被命名。该代码在 HTML 内容中搜索某些标签的 innerText 并将它们传输到 Excel 表格中，在标题下很好地排序，结构为枢轴。

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

它在 Excel 中完美运行，但我需要它用于 Access 表。我的名为 tblTab01 的 Aceess 表包含 headers = array("...") 中的代码中存在的所有字段，并且我禁用了以下行在代码中：

results = Application.Transpose(results)

和

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

相反，我添加了以下几行：

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

但我只会得到所有可能的错误！

如何修改代码以用于 Access 表？谢了

Answer 1

这会产生与 Excel 代码相同的输出。我尝试了一个消除循环数组的解决方案，但这个版本实际上更快。

必须使用 Excel WorksheetFunction 才能使 Transpose 方法起作用。确保在 References 中选择了 Excel 库。

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

取消注释 On Error 行：

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

然后，不是With ActiveSheet 块，而是遍历数组。

    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

根据我们的聊天讨论，表格中的所有字段都是文本类型。