我想使用Excel宏從網上繪制數據

Question

我想從http://arsiv.sahadan.com/genis_ekran_iddaa_programi/中獲取舊程序。 為此，我使用名為@QHarr的模塊修改了宏，但無法處理表。 宏不起作用。

    Public Sub Deneme()
    Application.ScreenUpdating = False
    Sheets("X").Select
    Cells.Delete Shift:=xlUp
    Range("A1").Select
    Dim url As String, ws As Worksheet, html As HTMLDocument, http As clsHTTP, hTable As HTMLTable
    Dim headerRow As Boolean, trow As Object, tRows As Object, tCell As Object, tCells As Object
    Dim iRow As Long, R As Long, C As Long, Hsay As Long, numberOfRequests As Long
    Dim hafta(), results(), headers()
    headers = Array("Hsay", "Saat", "Lig", "Kod", "MBS", "Ev Sahibi", "Misafir", "IY", "MS", "MS1", "MSX", "MS2", "IY1", "IYX", "IY2", "he", "H1", "HX", "H2", "hm", "KGV", "GVY", "CS1/X", "CS1/2", "X/2", "IY1,5A", "IY1,5U", "1,5A", "1,5U", "2,5A", "2,5U", "3,5A", "3,5U", "TG01", "TG23", "TG46", "7+")
    Set http = New clsHTTP
    Set ws = ThisWorkbook.Worksheets("X")
    Set html = New HTMLDocument
    hafta = Application.Transpose(Sheets("Y").Range("A1:A" & Sheets("Y").Range("A1048576").End(xlUp).Row).Value)
    Const numTableRows As Long = 500
    Const numTableColumns As Long = 37
    Const BASE_URL As String = "http://arsiv.sahadan.com/LargeProgram.aspx?"
    numberOfRequests = UBound(hafta)
    ReDim results(1 To numTableRows * numberOfRequests, 1 To numTableColumns)
    For Hsay = 1 To numberOfRequests
        headerRow = True
        url = BASE_URL & "id=weekId&value=" & hafta(Hsay)
        html.body.innerHTML = http.GetString(url)
        Set hTable = html.querySelector("dvLargeHead")
        Set tRows = hTable.getElementsByTagName("tr")
        For Each trow In tRows
            If Not headerRow Then
                C = 2: R = R + 1
                results(R, 1) = hafta(Hsay)
                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, 1).Resize(1, UBound(headers) + 1) = headers
        .Cells(2, 1).Resize(UBound(results, 1), UBound(results, 2)) = results
    End With
End Sub

Answer 1

我無法成功重現用於更新頁面的Ajax請求。 我得到“拒絕訪問”，這使我認為除了簡單的查詢字符串部分之外，我還必須缺少一些協議/身份驗證。

以下是使用硒基礎的示例。 這是很慢的，因為我正在復制所有格式，因為布局有點挑剔。

我寫的東西沒有使用剪貼板，如果我滿意的話，以后可以添加。 它快很多。

Option Explicit

Public Sub GetInfo()
    Dim d As WebDriver, clipboard As Object
    Dim ele As Object, ws As Worksheet, t As Date, weeks As Object, i As Long
    Const MAX_WAIT_SEC As Long = 15
    Set ws = ThisWorkbook.Worksheets("Sheet1")
    Set clipboard = GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
    Set d = New ChromeDriver
    Const URL = "http://arsiv.sahadan.com/genis_ekran_iddaa_programi/"

    With d
        .Start "Chrome"
        .get URL, timeout:=90000

        Set weeks = .FindElementsByCss("#weekId option")
        .FindElementByCss("[value='-1']").Click
        For i = 1 To weeks.Count
            If i > 1 Then
                .FindElementsByCss("#weekId option")(i).Click
            End If
            Dim html As HTMLDocument
            Set html = New HTMLDocument
            t = Timer
            Do
                DoEvents
                On Error Resume Next
                Set ele = .FindElementByCss("#dvLarge #resultsList")
                On Error GoTo 0
                If Timer - t > MAX_WAIT_SEC Then Exit Do
            Loop While ele Is Nothing

            If Not ele Is Nothing Then
                clipboard.SetText ele.Attribute("outerHTML")
                clipboard.PutInClipboard
                ws.Cells.UnMerge
                Application.Wait Now + TimeSerial(0, 0, 1)
                ws.Cells(GetLastRow(ws, 1) + 1, 1).PasteSpecial
                Application.Wait Now + TimeSerial(0, 0, 3)
            End If

            Set ele = Nothing
        Next
        .Quit
    End With

End Sub

Public Function GetLastRow(ByVal ws As Worksheet, Optional ByVal columnNumber As Long = 1) As Long
    With ws
        GetLastRow = .Cells(.Rows.Count, columnNumber).End(xlUp).Row
    End With
End Function