So I've been able to write a script that is able to pull stock fundamental data from Excel. Yay. I know the update has stumped many. Here is my current code. I am looking to interact with the webpage so that I can pull balance sheet and cashflow data as well. Also, I want to look at the data from a quarterly perspective and not annual. For ease of reference: https://finance.yahoo.com/quote/AAPL/financials?p=AAPL
This will require me to press a button on the screen; however, I am not sure how to go about doing this.
Sub importData()
For Each Chart In ActiveWorkbook.Charts
Chart.Delete
Next
Dim dashboardSheet As Worksheet
Dim dataSheet As Worksheet
Dim market As String
Dim startDate As String
Dim endDate As String
Dim frequencyCode As String ' Time Period
Dim dataURL As String 'URL for Historical Data
Dim dataURL2 As String 'URL for Balance Sheet
Dim i As Long ' Counter for Existing Connections
Application.ScreenUpdating = False
Set dashboardSheet = cnDash
Set dataSheet = cnData
market = dashboardSheet.Range("C2").Value
startDate = dashboardSheet.Range("A3").Value
endDate = dashboardSheet.Range("A4").Value
frequencyCode = dashboardSheet.Range("C6").Value
dataURL = "https://query1.finance.yahoo.com/v7/finance/download/" + market + "?period1=" + startDate + "&period2=" + endDate + "&interval=" + frequencyCode + "&events=history"
' Clear the existing connections
For i = ActiveWorkbook.Connections.Count To 1 Step -1
ActiveWorkbook.Connections.Item(i).Delete
Next
' Clear the Data
dataSheet.Cells.Delete
If dashboardSheet.ChartObjects.Count > 0 Then ' Delete sheet if it exists
dashboardSheet.ChartObjects.Delete
dashboardSheet.Paste
Else
dashboardSheet.Paste
End If
' Pull data from Yahoo for Historical Graph '
dataSheet.Activate
With ActiveSheet.QueryTables.Add(Connection:="TEXT;" & dataURL, _
Destination:=dataSheet.Range("A1"))
.Name = "import"
.FieldNames = True ' field names in source data appear as column headers
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 1252
.TextFileStartRow = 1 ' Start data from row 2 to exclude headings
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = True
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = True
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1, 1)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
'Pull data from Yahoo for Fundamentals '
Dim http As Object, s As String
Set http = CreateObject("MSXML2.XMLHTTP")
With http
.Open "GET", "https://finance.yahoo.com/quote/" + market + "/financials?p=", False
.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
.send
s = .responseText
End With
Dim html As MSHTML.HTMLDocument, html2 As MSHTML.HTMLDocument, re As Object, matches As Object
Set html = New MSHTML.HTMLDocument: Set html2 = New MSHTML.HTMLDocument
Set re = CreateObject("VBScript.RegExp")
Set element = html.getElementsByClassName("Fz(s) Fw(500) D(ib) H(18px) C($primaryColor):h C($linkColor)")
element.Click
html.body.innerHTML = s
Dim headers(), rows As Object
headers = Array("Breakdown", "TTM")
Set rows = html.querySelectorAll(".fi-row")
With re
.Global = True
.MultiLine = True
.Pattern = "\d{1,2}/\d{1,2}/\d{4}"
Set matches = .Execute(s)
End With
Dim results(), match As Object, r As Long, c As Long, startHeaderCount As Long
startHeaderCount = UBound(headers)
ReDim Preserve headers(0 To matches.Count + startHeaderCount)
c = 1
For Each match In matches
headers(startHeaderCount + c) = match
c = c + 1
Next
Dim row As Object
ReDim results(1 To rows.Length, 1 To UBound(headers) + 1)
For r = 0 To rows.Length - 1
html2.body.innerHTML = rows.Item(r).outerHTML
Set row = html2.querySelectorAll("[title],[data-test=fin-col]")
For c = 0 To row.Length - 1
results(r + 1, c + 1) = row.Item(c).innerText
Next c
Next
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("data")
With ws
.Cells(1, 10).Resize(1, UBound(headers) + 1) = headers
.Cells(2, 10).Resize(UBound(results, 1), UBound(results, 2)) = results
Columns("K:K").EntireColumn.AutoFit
Columns("L:L").EntireColumn.AutoFit
Columns("M:M").EntireColumn.AutoFit
Columns("N:N").EntireColumn.AutoFit
Columns("O:O").EntireColumn.AutoFit
Columns("J:J").EntireColumn.AutoFit
End With
Application.ScreenUpdating = True
Call HistoricalGraph(dataSheet, dashboardSheet, market)
End Sub
Here is my answer to scrape the exact page in R: Giving consent to cookies using rvest
To scrape this page, you need to run JS code. To do that in VBA, I think this is a good reference: https://ramblings.mcpher.com/get-started-snippets/step-by-step-guides/how-to-add-flightpaths-on-a-map/how-to-use-javascript-from-vba/
Related
I got this code from a competent user, not sure if he wants to be named. The code searches the HTML content for innerText of certain tags and transfers them to an Excel table, well sorted under the headers, structured as pivot.
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
It works perfectly in Excel, but I need it for an Access-table. My Aceess-table named tblTab01 contains all the fields that are present in the code in the headers = array("..."), and I have disabled the following lines in the code:
results = Application.Transpose(results)
and
ActiveSheet.Cells(1, 1).Resize(1, UBound(headers) + 1) = headers
Instead, I added the following lines:
Dim db As DAO.Database
Dim strInsert
Set db = CurrentDb
strInsert = "INSERT INTO tblTab01 VALUES (results);"
db.Execute strInsert
But I only get all possible errors!
How would the code need to be modified for use with the Access table? THX
This produces same output as the Excel code. I attempted a solution that eliminated looping array but this version is actually faster.
Had to use Excel WorksheetFunction to make the Transpose method work. Make sure Excel library is selected in References.
results = Excel.WorksheetFunction.Transpose(results)
ReDim Preserve results(1 To UBound(headers) + 1, 1 To r)
results = Excel.WorksheetFunction.Transpose(results)
Uncomment the On Error lines:
On Error Resume Next
results(r, 8) = re.Execute(.document.querySelector("#anz").innerHTML)(0).Submatches(0)
On Error GoTo 0
Then instead of the With ActiveSheet block, loop through array.
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
All fields in table are text type, per our chat discussion.
I have looked at the solution provided in this link Extract Table from Webpage in Excel using VBA and it was very helpful. But I need to extract the values in the div classes (cscore_score) and not a table Please refer to image below
The URL is: https://www.espncricinfo.com/scores
The div class is: cscore_score
The scores to extract is in nested divs. The sample data for each nested div I want to extract is like Country and Score i.e INDIA and in the next column "416..." into the Excel sheet.
Here's a screenshot of the table structure:
Public Sub GetInfo()
Const URL As String = "https://www.espncricinfo.com/scores"
Dim html As HTMLDocument, hTable As HTMLTable, ws As Worksheet, headers()
Set ws = ThisWorkbook.Worksheets("Sheet1")
Set html = New HTMLDocument
With CreateObject("MSXML2.XMLHTTP")
.Open "GET", URL, False
.send
html.body.innerHTML = .responseText
End With
Set hDiv = html.querySelector("div.cscore")
Dim ul As Object, div As Object, r As Long, c As Long
r = 1
With ws
For Each div In hDiv.getElementsByClassName("cscore_link")
r = r + 1: c = 1
If r > 3 Then
For Each ul In div.getElementsByClassName("cscore_score")
.Cells(r - 2, c) = IIf(c = 2, "'" & div.innerText, div.innerText)
c = c + 1
Next
End If
Next
End With
End Sub
I would be grateful to receive any help to extract those scores from each div into the sheet.
You could use faster css selectors (using only class is faster than tag/type) which if used as shown below will allow you to also reduce your code complexity and improve performance by having only a single loop. Results can then be stored in an array and written out in one go - again another efficiency gain.
Note I am ensuring scores remain correctly formatted on output by concatenating "'" in front.
If you want scores for same match on same row:
Option Explicit
Public Sub GetData()
Dim html As HTMLDocument, ws As Worksheet, countries As Object, scores As Object, results(), i As Long, r As Long
Set ws = ThisWorkbook.Worksheets("Sheet1"): Set html = New HTMLDocument: r = 1
With CreateObject("MSXML2.XMLHTTP")
.Open "GET", "https://www.espncricinfo.com/scores", False
.send
html.body.innerHTML = .responseText
End With
Set countries = html.querySelectorAll(".cscore--watchNotes .cscore_name--long"): Set scores = html.querySelectorAll(".cscore_score ")
ReDim results(1 To countries.Length / 2, 1 To 4)
For i = 0 To countries.Length - 1 Step 2
results(r, 1) = countries.item(i).innerText: results(r, 2) = "'" & scores.item(i).innerText
results(r, 3) = countries.item(i + 1).innerText: results(r, 4) = "'" & scores.item(i + 1).innerText
r = r + 1
Next
ws.Cells(1, 1).Resize(1, 4) = Array("Home", "Score", "Away", "Score")
ws.Cells(2, 1).Resize(UBound(results, 1), UBound(results, 2)) = results
End Sub
Scores on different rows for every team:
Option Explicit
Public Sub GetData()
Dim html As HTMLDocument, ws As Worksheet, countries As Object, scores As Object, results(), i As Long
Set ws = ThisWorkbook.Worksheets("Sheet1"): Set html = New HTMLDocument
With CreateObject("MSXML2.XMLHTTP")
.Open "GET", "https://www.espncricinfo.com/scores", False
.send
html.body.innerHTML = .responseText
End With
Set countries = html.querySelectorAll(".cscore--watchNotes .cscore_name--long"): Set scores = html.querySelectorAll(".cscore_score ")
ReDim results(1 To countries.Length, 1 To 2)
For i = 0 To countries.Length - 1
results(i + 1, 1) = countries.item(i).innerText: results(i + 1, 2) = "'" & scores.item(i).innerText
Next
ws.Cells(1, 1) = "Country": ws.Cells(1, 2) = "Score"
ws.Cells(2, 1).Resize(UBound(results, 1), UBound(results, 2)) = results
End Sub
Additional column:
Public Sub GetData()
Dim html As HTMLDocument, ws As Worksheet, countries As Object, scores As Object
Dim descs As Object, results(), i As Long, r As Long
Set ws = ThisWorkbook.Worksheets("Sheet1"): Set html = New HTMLDocument: r = 1
With CreateObject("MSXML2.XMLHTTP")
.Open "GET", "https://www.espncricinfo.com/scores", False
.send
html.body.innerHTML = .responseText
End With
Set countries = html.querySelectorAll(".cscore--watchNotes .cscore_name--long"): Set scores = html.querySelectorAll(".cscore_score ")
Set descs = html.querySelectorAll(".cscore--watchNotes .cscore_info-overview")
ReDim results(1 To countries.Length / 2, 1 To 5)
For i = 0 To countries.Length - 1 Step 2
results(r, 1) = descs.Item(i / 2).innerText
results(r, 2) = countries.Item(i).innerText: results(r, 3) = "'" & scores.Item(i).innerText
results(r, 4) = countries.Item(i + 1).innerText: results(r, 5) = "'" & scores.Item(i + 1).innerText
r = r + 1
Next
ws.Cells(1, 1).Resize(1, 5) = Array("Desc", "Home", "Score", "Away", "Score")
ws.Cells(2, 1).Resize(UBound(results, 1), UBound(results, 2)) = results
End Sub
Your request seems to be just fine. Parsing the HTML is where your problem is.
You could do something like the following (you can ignore the request part):
Option Explicit
Sub espn()
Dim req As New WinHttpRequest
Dim HTMLDocument As New HTMLDocument
Dim listElement As HTMLUListElement
Dim listItem As HTMLLIElement
Dim sht As Worksheet
Dim i As Long
Dim j As Long
Dim url As String
url = "https://www.espncricinfo.com/scores"
With req
.Open "GET", url, False
.send
HTMLDocument.body.innerHTML = .responseText
End With
Set sht = ThisWorkbook.Worksheets("Name of your worksheet")
i = 2
For Each listElement In HTMLDocument.getElementsByClassName("cscore_competitors")
j = 1
For Each listItem In listElement.getElementsByTagName("li")
sht.Cells(i, j) = listItem.getElementsByClassName("cscore_name cscore_name--long")(0).innerText
sht.Cells(i, j + 1) = listItem.getElementsByClassName("cscore_score")(0).innerText
j = j + 2
Next listItem
i = i + 1
Next listElement
End Sub
The results would look like so:
Basically each game is represented by a ul (unnumbered list) element which consists of two li elements which contain the info about the names and the score.
I want to download the Excel file attached to html via Excel vba and output it in Excel sheet. This homepage is a list of the current status of the box office that has been popular in Korean movie theaters.
http://www.kobis.or.kr/kobis/business/stat/boxs/findFormerBoxOfficeList.do?loadEnd=0&searchType=search&sMultiMovieYn=&sRepNationCd=&sWideAreaCd=
Attached file is Excel. I understand that downloading can be done using the click method through Internet search. However, an alert window appears during downloading of the file, and the date is inserted in the name of the Excel file to be downloaded. As a beginner in Excel VBA it is very difficult. So I left this question, and what logic would it be useful to implement to spread this file on an Excel sheet? I am a beginner in Excel VBA so if you give me a detailed answer, it will be really helpful.
<p class = "btn_regi">
<a href="#none" class="btn_type01" onclick="chkform('excel'); return false ;">
<strong> Excel </ strong> </a>
</ p>
The following logic I have coded myself until dawn. However, the logic was too inefficient and the results did not work so I asked for help.
Sub program_()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim bridge As String
Dim WinHttp As New WinHttpRequest
Dim sResponse As String, html As New HTMLDocument, hStructure As Object, hTable As HTMLTable
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1")
Set WinHttp = CreateObject("WinHttp.WinHttpRequest.5.1")
Dim Url As String
Url = "http://www.kobis.or.kr/kobis/business/stat/boxs/findFormerBoxOfficeList.do?"
Dim p1 As String 'parameter
Dim v1 As String
Dim p2 As String
Dim v2 As String
Dim p3 As String
Dim v3 As String
Dim p4 As String
Dim v4 As String
Dim p5 As String
Dim v5 As String
Dim v As Integer
Dim g As Integer
bridge = "&"
p1 = "loadEnd="
v1 = 0
p2 = "searchType="
v2 = "search"
p3 = "sMultiMovieYn="
v3 = ""
p4 = "sRepNationCd="
v4 = ""
p5 = "sWideAreaCd="
v5 = ""
With WinHttp
.Open "get", "" & Url & p1 & v1 & bridge & p2 & v2 & bridge & p3 & v3 & bridge & p4 & v4 & bridge & p5 & v5 & ""
.SetRequestHeader "Referer", "http://www.kobis.or.kr/kobis/business/stat/boxs/findFormerBoxOfficeList.do?"
.SetRequestHeader "Content-Type", "application/x-www-form-urlencoded"
.Send
.WaitForResponse ': DoEvents
sResponse = StrConv(.responseBody, vbUnicode)
Dim hforms As HTMLFormElement
With html
.body.innerHTML = sResponse
sResponse = ""
Set hTable = .getElementsByClassName("boardList03")(0)
End With
Dim Arr0() As Variant
Dim tRow As Object, tCell As Object, tr As Object, td As Object, r As Long, c As Long
r = 0
With ws
Set tRow = hTable.getElementsByTagName("tbody")(0).getElementsByTagName("tr")
ReDim Arr0(tRow.Length - 1, 10)
For Each tr In tRow
r = r + 1
Set tCell = tr.getElementsByTagName("td")
Dim j As Integer
c = 1
For Each td In tCell
If td.ID = "td_rank" Then
Arr0(r - 1, 0) = td.innerText
End If
If td.ID = "td_movie" Then
Arr0(r - 1, 1) = td.getElementsByTagName("a")(0).innerText
End If
If td.ID = "td_openDt" Then
Arr0(r - 1, 2) = td.innerText
End If
If td.ID = "td_salesAcc" Then
Arr0(r - 1, 3) = td.innerText
End If
If td.ID = "td_audiAcc" Then
Arr0(r - 1, 4) = td.innerText
End If
If td.ID = "td_scrnCnt" Then
Arr0(r - 1, 5) = td.innerText
End If
If td.ID = "td_showCnt" Then
Arr0(r - 1, 6) = td.innerText
End If
c = c + 1
Next td
Next tr
Dim k As Integer
Dim i As Integer
k = 0
For i = LBound(Arr0, 1) To UBound(Arr0, 1)
.Cells(2 + k + g, 2) = Arr0(i, 0)
.Cells(2 + k + g, 3) = Arr0(i, 1)
.Cells(2 + k + g, 4) = Arr0(i, 2)
.Cells(2 + k + g, 5) = Arr0(i, 3)
.Cells(2 + k + g, 6) = Arr0(i, 4)
.Cells(2 + k + g, 7) = Arr0(i, 5)
.Cells(2 + k + g, 8) = Arr0(i, 6)
k = k + 1
Next i
End With
Erase Arr0
Set tRow = Nothing: Set tCell = Nothing: Set tr = Nothing: Set td = Nothing
Set hforms = Nothing
Set hTable = Nothing
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
You could just grab the table by its id and then loop the table rows and table cells within rows.
Option Explicit
Public Sub GetInfo()
Dim IE As New InternetExplorer, hTable As HTMLTable
Const MAX_WAIT_SEC As Long = 5
Application.ScreenUpdating = False
With IE
.Visible = True
.navigate "http://www.kobis.or.kr/kobis/business/stat/boxs/findFormerBoxOfficeList.do?loadEnd=0&searchType=search&sMultiMovieYn=&sRepNationCd=&sWideAreaCd="
While .Busy Or .readyState < 4: DoEvents: Wend
Set hTable = .document.getElementById("table_former")
WriteTable hTable, 1, ThisWorkbook.Worksheets("Sheet1")
.Quit
Application.ScreenUpdating = True
End With
End Sub
Public Sub WriteTable(ByVal hTable As HTMLTable, Optional ByVal startRow As Long = 1, Optional ByVal ws As Worksheet)
If ws Is Nothing Then Set ws = ActiveSheet
Dim tSection As Object, tRow As Object, tCell As Object, tr As Object, td As Object, r As Long, c As Long, tBody As Object
r = startRow
With ws
Dim headers As Object, header As Object, columnCounter As Long
Set headers = hTable.getElementsByTagName("th")
For Each header In headers
columnCounter = columnCounter + 1
.Cells(startRow, columnCounter) = header.innerText
Next header
startRow = startRow + 1
Set tBody = hTable.getElementsByTagName("tbody")
For Each tSection In tBody 'HTMLTableSection
Set tRow = tSection.getElementsByTagName("tr") 'HTMLTableRow
For Each tr In tRow
r = r + 1
Set tCell = tr.getElementsByTagName("td")
c = 1
For Each td In tCell 'DispHTMLElementCollection
.Cells(r, c).Value = td.innerText 'HTMLTableCell
c = c + 1
Next td
Next tr
Next tSection
End With
End Sub
References (VBE> Tools > References):
Microsoft HTML Object Library
Microsoft Internet Controls
This code (like other codes) written by Precious #QHarr works well. However, when importing data, I want to retrieve the data saved in the connection. The output of the code and the data I want to receive are shown in the attached image. What kind of code can I solve? (Google Translate)
Public Sub DYarislar()
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", "K.Cinsi", "Gr", "Msf/Pist", "Derece", "S", "Jokey", "Kilo", "G.Ç", "Hnd", "Gny", "Taki")
Set http = New clsHTTP
Set ws = ThisWorkbook.Worksheets("X")
Set html = New HTMLDocument
asays = Application.Transpose(Sheets("Y").Range("A2:A" & Sheets("Y").Columns("A:A").Find(What:="boş").Row - 1).Value)
Const numTableRows As Long = 250
Const numTableColumns As Long = 14
Const BASE_URL As String = "https://yenibeygir.com/at/"
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_Yarislar")
Set tRows = hTable.getElementsByTagName("tr")
Const numberOfRaces As Long = 22
Dim counter As Long
counter = 1
For Each tRow In tRows
If Not headerRow Then
counter = counter + 1
If counter > numberOfRaces Then Exit For
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, 1).Resize(1, UBound(headers) + 1) = headers
.Cells(2, 1).Resize(UBound(results, 1), UBound(results, 2)) = results
End With
Application.ScreenUpdating = True
End Sub
You only need a few small changes. You use the same Class, clsHTTP, as before, then use the module 1 code below.
Notes:
Within each source page table row the jockey column contains an a tag link element
You can access this using:
tRow.getElementsByTagName("a")(1).href
As the link is relative you need to do a text replacement to add in the base part of the URL i.e.
Replace$(tRow.getElementsByTagName("a")(1).href, "about:", BASE_URL2)
The id is part of the href and can be extracted using Split:
Split(tRow.getElementsByTagName("a")(1).href, "/")(2)
To allow for these additional elements in the results you need to increase the number of output column count:
Const numTableColumns As Long = 16
And adapt your table rows loop to populate the additional columns:
results(r, 2) = Split(tRow.getElementsByTagName("a")(1).href, "/")(2)
results(r, 3) = Replace$(tRow.getElementsByTagName("a")(1).href, "about:", BASE_URL2)
Also, adjust in the loop to ensure other columns are populated from the 4th onwards (as 2 extra columns):
c = 4
Finally, adjust your headers to include the 2 new columns:
headers = Array("Asay", "JokeyId", "JokeyLink", "Tarih", "Sehir", "K.Cinsi", "Gr", "Msf/Pist", "Derece", "S", "Jokey", "Kilo", "G.Ç", "Hnd", "Gny", "Taki")
VBA:
Module 1:
Option Explicit
Public Sub DYarislar()
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", "JokeyId", "JokeyLink", "Tarih", "Sehir", "K.Cinsi", "Gr", "Msf/Pist", "Derece", "S", "Jokey", "Kilo", "G.Ç", "Hnd", "Gny", "Taki")
Set http = New clsHTTP
Set ws = ThisWorkbook.Worksheets("X")
Set html = New HTMLDocument
asays = Application.Transpose(Sheets("Y").Range("A2:A" & Sheets("Y").Columns("A:A").Find(What:="boş").Row - 1).Value)
Const numTableRows As Long = 250
Const numTableColumns As Long = 16
Const BASE_URL As String = "https://yenibeygir.com/at/"
Const BASE_URL2 As String = "https://yenibeygir.com"
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_Yarislar")
Set tRows = hTable.getElementsByTagName("tr")
For Each tRow In tRows
If Not headerRow Then
c = 4: r = r + 1
results(r, 1) = asays(asay)
On Error Resume Next
results(r, 2) = Split(tRow.getElementsByTagName("a")(1).href, "/")(2)
results(r, 3) = Replace$(tRow.getElementsByTagName("a")(1).href, "about:", BASE_URL2)
On Error GoTo 0
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
Sample results:
There is a program that parse a certain table from the site . Works great . I want to parse another table from the site . By the tag number “table” they are the same . I am trying to use the same program , but it gives an error : Run-time error 91 in the line :
If oRow.Cells(y).Children.Length > 0 Then
New table : http://allscores.ru/soccer/fstats.php?champ=2604&team=439&team2=420&tour=110
Old table : http://allscores.ru/soccer/new_ftour.php?champ=2604&f_team=439
New table : in the attached picture
Function extractTable(Ssilka As String, book1 As Workbook, iLoop As Long)
Dim oDom As Object, oTable As Object, oRow As Object
Dim iRows As Integer, iCols As Integer
Dim x As Integer, y As Integer
Dim data()
Dim vata()
Dim tata()
Dim oHttp As Object
Dim oRegEx As Object
Dim sResponse As String
Dim oRange As Range
Dim odRange As Range
' get page
Set oHttp = CreateObject("MSXML2.XMLHTTP")
oHttp.Open "GET", Ssilka, False
oHttp.Send
' cleanup response
sResponse = StrConv(oHttp.responseBody, vbUnicode)
Set oHttp = Nothing
sResponse = Mid$(sResponse, InStr(1, sResponse, "<!DOCTYPE "))
Set oRegEx = CreateObject("vbscript.regexp")
With oRegEx
.MultiLine = True
.Global = True
.IgnoreCase = False
.Pattern = "<(script|SCRIPT)[\w\W]+?</\1>"
sResponse = .Replace(sResponse, "")
End With
Set oRegEx = Nothing
' create Document from response
Set oDom = CreateObject("htmlFile")
oDom.Write sResponse
DoEvents
' table with results, indexes starts with zero
Set oTable = oDom.getelementsbytagname("table")(3)
DoEvents
iRows = oTable.Rows.Length
iCols = oTable.Rows(1).Cells.Length
' first row and first column contain no intresting data
ReDim data(1 To iRows - 1, 1 To iCols - 1)
ReDim vata(1 To iRows - 1, 1 To iCols - 1)
ReDim tata(1 To iRows - 1, 1 To iCols - 1)
' fill in data array
For x = 1 To iRows - 1
Set oRow = oTable.Rows(x)
For y = 1 To iCols - 1
If oRow.Cells(y).Children.Length > 0 Then
data(x, y) = oRow.Cells(y).getelementsbytagname("a")(0).getattribute("href")
data(x, y) = Replace(data(x, y), "about:", "http://allscores.ru/soccer/")
vata(x, y) = oRow.Cells(y).innerText
End If
Next y
Next x
Set oRow = Nothing
Set oTable = Nothing
Set oDom = Nothing
Set oRange = book1.ActiveSheet.Cells(110, 26 + (iLoop * 21)).Resize(iRows - 1, iCols - 1)
oRange.NumberFormat = "#"
oRange.Value = data
Set odRange = book1.ActiveSheet.Cells(34, 26 + (iLoop * 21)).Resize(iRows - 1, iCols - 1)
odRange.NumberFormat = "#"
odRange.Value = vata
Set oRange = Nothing
Set odRange = Nothing
End Function
This is not particularly robust but does grab the values from the table. iLoop is not used.
Option Explicit
Public Sub test()
extractTable "http://allscores.ru/soccer/fstats.php?champ=2604&team=439&team2=420&tour=110", ThisWorkbook, 1
End Sub
Public Sub extractTable(Ssilka As String, book1 As Workbook)
Dim oDom As Object, oTable As Object
Dim oHttp As Object
Dim oRegEx As Object
Dim sResponse As String
Set oHttp = CreateObject("MSXML2.XMLHTTP")
oHttp.Open "GET", Ssilka, False
oHttp.send
sResponse = StrConv(oHttp.responseBody, vbUnicode)
Set oHttp = Nothing
sResponse = Mid$(sResponse, InStr(1, sResponse, "<!DOCTYPE "))
Set oRegEx = CreateObject("vbscript.regexp")
With oRegEx
.MultiLine = True
.Global = True
.IgnoreCase = False
.Pattern = "<(script|SCRIPT)[\w\W]+?</\1>"
sResponse = .Replace(sResponse, "")
End With
Set oRegEx = Nothing
Set oDom = CreateObject("htmlFile")
oDom.Write sResponse
Set oTable = oDom.getElementsByTagName("table")(3)
Dim b As Object, a As Object
Set b = oTable.getElementsByTagName("TR") 'DispHTMLElementCollection
Dim i As Long, y As Long
With ActiveSheet
For i = 3 To 17 '17-3 gives the 15 rows of interest. Start at 3 to avoid header and empty row.
Set a = b(i).ChildNodes
For y = 1 To a.Length - 1
.Cells(i - 2, y) = a(y).innerText
Next y
Next i
End With
End Sub