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周期中获取大量数据，但过一会儿页面挂起。如何在每个周期结束时重置对象？

Asay数字 10182 10221 10279 10303 10316 10325 10360 10370 10680 11598 11629 11715 11745 12335 12385 12533 12559 13154 13393 13635 13641 13669 13673 14027 14057 14062 14228 14619 14674 14687 14743 14770 14778 15197 15217 15323 15382 15507 15775 15828 16077 16335 16510 17149 17513 17867 18532 37964 60176 66067 66255 66581 66582 66896 66998 67056 67309 67356 67379 67473 68008 68012 68162 68298 68312 68320 68332 68333 68353 68383 68545 68702 68775 68922 69445 69606 69817 69963 69968 69985 69986 70048 70202 71372 （boş）

Answer 1

如果您尝试快速连续多次访问站点，则可能是由于网络限制而导致速度变慢。考虑到您的访问方法，这尤其可能。最好查看API是否可用于批量访问信息。您可能还会通过许多网络访问此页面。可以从命令提示符处从TRACERT命令获取一些有关延迟的基本信息。

您正在执行POST，因此请记住，还有大量服务器端内容正在运行。

您不需要将elem设置为Nothing，因为它仅存在于您的For Loop中。与tRow相同。

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

首先将结果写入数组，然后一次将数组转储到工作表中，将大大提高速度。

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

我个人会作弊并重新编写，以利用您可以发出GET请求来获取相同的信息。我使用一个类来保存XMLHTTP对象，并使用一个数组来保存结果。我一口气把结果写出来。这需要几秒钟才能为我运行。 Asay编号在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

参考网址：

Microsoft HTML对象库

Answer 2

通常需要Set elem = Nothing。

在代码中，您是在for-each循环中分配变量，因此，即使以后将它们设置为Nothing，也不会带来性能上的好处。

Answer 3

尝试将这些对象设置为Nothing，如下所示：

Set elem = Nothing
Set trow = Nothing

我不确定循环中是否需要变量声明，可以将其从循环中删除，这样可以节省一些时间。

但是我认为您的HTTP请求花费了很长时间，而不是任何VBA代码。

更新

尝试在宏开始时将Application.EnableEvents和Application.ScreenUpdating设置为False，最后将它们重新设置为True。

如何清除Excel vba中的对象？

3 个答案: