Argthtjtr

I want to take old programs from http://arsiv.sahadan.com/genis_ekran_iddaa_programi/. For this I modified the macro with the module called @QHarr, but I couldn't handle the tables. Macro doesn't work.

    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

I cannot successfully reproduce the ajax requests that are used to update the page. I get Access Denied which makes me think there must be some protocol/authentication I am missing beyond the simple query string part.

Below is an example using selenium basic. It is slow as I am copying all the formatting across as the layout is a little finicky.

I have written something without using the clipboard which I may add later if I am happy with. It is a lot faster.

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