html - 如何清理 Excel vba 中的对象？

Question

Public Sub D_Galoplar()
    Application.ScreenUpdating = False
    Dim Asay(1 To 250)
    Dim Jsay(1 To 100)
    For q = 2 To Sheets("Y").Columns("A:A").Find(What:="boş").Row - 1
        Asay(q - 1) = Sheets("Y").Range("A" & q)
    Next q
    For q = 2 To Sheets("Y").Columns("C:C").Find(What:="boş").Row - 1
        Jsay(q - 1) = Sheets("Y").Range("C" & q)
    Next q
For w = 1 To 250
    Cells.Delete Shift:=xlUp
    Range("A1").Select
    If Asay(w) < 1 Then Exit For

    Dim elem As Object, trow As Object
    Dim R&, C&, s$
    With New XMLHTTP60
        .Open "POST", "https://yenibeygir.com/at/getatdetaytab", False
        .setRequestHeader "content-type", "application/x-www-form-urlencoded; charset=UTF-8"
        .send "tab=galopTab&id=" & Asay(w)
        s = .responseText
    End With
    With New HTMLDocument
        .body.innerHTML = s
        For Each elem In .getElementsByClassName("at_Galoplar")(0).Rows
            For Each trow In elem.Cells
                C = C + 1: Cells(R + 1, C) = trow.innerText
            Next trow
            C = 0: R = R + 1
        Next elem
    End With

    Cells.UnMerge
    Range("A1").Select

    If Range("A1048576").End(xlUp).Row < 2 Then GoTo ATLA2

    Columns("A:A").Insert
    For i = 2 To Range("B1048576").End(xlUp).Row - 1
        Range("A" & i) = Asay(w)
    Next i

    Range("O2").FormulaR1C1 = "=IF(ISBLANK(RC[-9]),""-"",IF(ISNUMBER(RC[-9]),RC[-9]/4,((LEFT(RC[-9],1)*6000)+(MID(RC[-9],3,2)*100)+(RIGHT(RC[-9],1)*10))/400))"
    Range("P2").FormulaR1C1 = "=IF(ISBLANK(RC[-9]),""-"",IF(ISNUMBER(RC[-9]),RC[-9]/6,((LEFT(RC[-9],1)*6000)+(MID(RC[-9],3,2)*100)+(RIGHT(RC[-9],1)*10))/600))"
    Range("Q2").FormulaR1C1 = "=IF(ISBLANK(RC[-9]),""-"",IF(ISNUMBER(RC[-9]),RC[-9]/8,((LEFT(RC[-9],1)*6000)+(MID(RC[-9],3,2)*100)+(RIGHT(RC[-9],1)*10))/800))"
    Range("R2").FormulaR1C1 = "=IF(ISBLANK(RC[-9]),""-"",IF(ISNUMBER(RC[-9]),RC[-9]/10,((LEFT(RC[-9],1)*6000)+(MID(RC[-9],3,2)*100)+(RIGHT(RC[-9],1)*10))/1000))"
    Range("S2").FormulaR1C1 = "=IF(ISBLANK(RC[-9]),""-"",IF(ISNUMBER(RC[-9]),RC[-9]/12,((LEFT(RC[-9],1)*6000)+(MID(RC[-9],3,2)*100)+(RIGHT(RC[-9],1)*10))/1200))"
    Range("T2").FormulaR1C1 = "=IF(ISBLANK(RC[-9]),""-"",IF(ISNUMBER(RC[-9]),RC[-9]/14,((LEFT(RC[-9],1)*6000)+(MID(RC[-9],3,2)*100)+(RIGHT(RC[-9],1)*10))/1400))"
    Range("O2:T2").Copy
    Range("O2:O" & Range("A1048576").End(xlUp).Row).PasteSpecial Paste:=xlPasteFormulas
    Cells.Copy
    Cells.PasteSpecial Paste:=xlPasteValues
    Columns("O:T").Cut Columns("F:K")

    Range("A2:N" & Range("A1048576").End(xlUp).Row).Copy
    Sheets("Galop").Range("A" & Sheets("Galop").Range("A1048576").End(xlUp).Row + 1).PasteSpecial Paste:=xlPasteValues

ATLA2:
    Cells.Delete Shift:=xlUp
Next w
End Sub

我想用 For Next 循环获取大量数据，但过了一会儿页面挂起。如何在每个循环结束时重置对象？

化验数字101821022110279103031031610325103601037010680115981162911715117451233512385125331255913154133931363513641136691367314027140571406214228146191467414687147431477014778151971521715323153821550715775158281607716335165101714917513178671853237964601766606766255665816658266896669986705667309673566737967473680086801268162682986831268320683326833368353683836854568702687756892269445696066981769963699686998569986700487020271372(博斯)

Answer 1

如果您试图快速连续多次访问该站点，则速度可能会因网络限制而降低。考虑到您的访问方法，这种情况特别有可能发生。最好查看是否有 API 可用于批量访问信息。您也可能会通过许多网络来访问此页面。可以从 TRACERT 获得一些关于延误的基本信息。命令提示符下的命令。

您正在执行 POST，因此请记住还有相当多的服务器端内容在进行。

您不需要将 elem 设置为 Nothing，因为它仅在您的 For 循环 期间存在。 tRow 也是如此。

将 .getElementsByClassName("at_Galoplar")(0).Rows 放入变量中将提供更快的引用。

先将结果写入数组，然后将数组一次性转储到 sheet 中，这样可以显着提高速度。

使用 New 关键字可能会导致意外行为。您可以创建 HTMLDocument 的一个实例并使用它，前提是您有良好的错误处理能力。我在循环中遇到过偶尔的情况，我不得不将 HTMLDocument 设置为 Nothing 在循环之前。

---

就个人而言，我会作弊并重写它以利用您可以发出 GET 请求来获取相同的信息。我使用一个类来保存 XMLHTTP 对象，并使用一个数组来保存结果。我一口气把结果写出来。这需要几秒钟才能为我运行。检测编号在 Sheet1 范围内 A1:A84。

类模块 clsHTTP

Option Explicit    
Private http As Object

Private Sub Class_Initialize()
    Set http = CreateObject("MSXML2.XMLHTTP")
End Sub

Public Function GetString(ByVal url As String) As String
    Dim sResponse As String
    With http
        .Open "GET", url, False
        .setRequestHeader "If-Modified-Since", "Sat, 1 Jan 2000 00:00:00 GMT"
        .send
        sResponse = StrConv(.responseBody, vbUnicode)
        GetString = sResponse
    End With
End Function

标准模块1

Option Explicit
Public Sub DGaloplar()
    Dim asays(), ws As Worksheet, asay As Long, html As HTMLDocument
    Dim http As clsHTTP, url As String, headers(), numberOfRequests As Long

    headers = Array("Asay", "Tarih", "Sehir", "Kg", "Jokey", "400", "600", "800", "1000", "1200", "1400", "Ç", "Pist", "Durum")
    Set http = New clsHTTP
    Set ws = ThisWorkbook.Worksheets("Sheet1")
    Set html = New HTMLDocument
    asays = Application.Transpose(ws.Range("A1:A84").Value) 'Load asay values from sheet 1

    Const numTableRows As Long = 11
    Const numTableColumns As Long = 15
    Const BASE_URL As String = "https://yenibeygir.com/at/getatdetaytab/?tab=galopTab&id="

    numberOfRequests = UBound(asays)

    Dim results(), headerRow As Boolean, tRows As Object, tRow As Object, iRow As Long
    Dim tCells As Object, tCell As Object, r As Long, c As Long, hTable As HTMLTable
    ReDim results(1 To numTableRows * numberOfRequests, 1 To numTableColumns)

    Application.ScreenUpdating = False

    For asay = 1 To numberOfRequests
        headerRow = True
        url = BASE_URL & asays(asay)
        html.body.innerHTML = http.GetString(url)
        Set hTable = html.querySelector(".at_Galoplar")
        Set tRows = hTable.getElementsByTagName("tr")

        For Each tRow In tRows
            If Not headerRow Then
                c = 2: r = r + 1
                results(r, 1) = asays(asay)
                Set tCells = tRow.getElementsByTagName("td")
                For Each tCell In tCells
                    results(r, c) = tCell.innerText
                    c = c + 1
                Next
            End If
            headerRow = False
        Next
    Next

    With ws
        .Cells(1, 3).Resize(1, UBound(headers) + 1) = headers
        .Cells(2, 3).Resize(UBound(results, 1), UBound(results, 2)) = results
    End With
    Application.ScreenUpdating = True
End Sub

---

引用:

1. Microsoft HTML 对象库