Web table's specified cell import to excel

[mikol]

0
I would like to import one cell from a web table to excel.
This is the daily price of copper.
I find for the code and found one part of this.
Please help me to complete the code which imports only the cell in the second row, and second column.
Thx!

 Dim htm As Object
   Dim Tr As Object
   Dim Td As Object
   Dim Tab1 As Object
   Dim URL As String
   Dim Colstart As Long
   Dim html As Variant
   Dim i As Long
   Dim j As Long
   Dim n As Long
   Dim szoveg1 As String

szoveg1 = "https://www.kabelring.hu/arfolyamok"
   Application.ScreenUpdating = False

     URL = szoveg1

   Set html = CreateObject("htmlfile") 'Create HTMLFile Object
   With CreateObject("msxml2.xmlhttp") 'Get the WebPage Content
      .Open "GET", URL, False
      .send
      html.body.innerHTML = .responseText
   End With

   Colstart = 1 'vízszintes eltolás
   j = 1 'függőleges eltolás
   i = Colstart
   n = 0

   'Loop Through website tables
   For Each Tab1 In html.getElementsByTagName("table")
      With html.getElementsByTagName("table")(n)
        For Each Tr In .Rows
            For Each Td In Tr.Cells
               Munka1.Cells(j, i) = Td.innerText
               i = i + 1 'táblázaton belüli függőleges beolvasás
            Next Td
            i = Colstart
            j = j + 1 'adatok közötti függőleges cellatávolság
          Next Tr
      End With

      n = n + 1
      i = Colstart
      j = j + 1
   Next Tab1

 Application.ScreenUpdating = True
End Sub

 

[Marc L]

A VBA demonstration for starters :​

Sub DemoReq1()
      Const C = "Alu = "
        Dim T$, L&
    With CreateObject("WinHttp.WinHttpRequest.5.1")
       .Open "GET", "https://www.kabelring.hu/arfolyamok", False
       .setRequestHeader "DNT", "1"
        On Error Resume Next
       .send
        T = .responseText
    End With
        If Err.Number Then Beep: Exit Sub
        On Error GoTo 0
        L = InStr(T, C)
        If L Then MsgBox Split(Mid(T, L + Len(C)), , 2)(0), , C
End Sub

 

[Marc L]

A variation for 'Réz' :​

Sub DemoReq1v()
      Const C = "Réz = "
        Dim V
    With CreateObject("WinHttp.WinHttpRequest.5.1")
       .Open "GET", "https://www.kabelring.hu/arfolyamok", False
       .setRequestHeader "DNT", "1"
        On Error Resume Next
       .send
        V = Split(.responseText, C)
    End With
        On Error GoTo 0
        If IsArray(V) Then If UBound(V) > 0 Then MsgBox Split(V(1), , 2)(0), , C
End Sub

 

[mikol]

A variation for 'Réz' :​

Sub DemoReq1v()
      Const C = "Réz = "
        Dim V
    With CreateObject("WinHttp.WinHttpRequest.5.1")
       .Open "GET", "https://www.kabelring.hu/arfolyamok", False
       .setRequestHeader "DNT", "1"
        On Error Resume Next
       .send
        V = Split(.responseText, C)
    End With
        On Error GoTo 0
        If IsArray(V) Then If UBound(V) > 0 Then MsgBox Split(V(1), , 2)(0), , C
End Sub

Thanks a lot! I like it!
And could change the messagebox to write data to cell? For example Sheet1, A1?
I tried with ".Range", but I didn't get good solution.

THX!

 

[mikol]

Thanks a lot! I like it!
And could change the messagebox to write data to cell? For example Sheet1, A1?
I tried with ".Range", but I didn't get good solution.

THX!

Maybe?

Sub DemoReq1v()
      Const C = "Réz = "
        Dim V
    With CreateObject("WinHttp.WinHttpRequest.5.1")
       .Open "GET", "https://www.kabelring.hu/arfolyamok", False
       .setRequestHeader "DNT", "1"
        On Error Resume Next
       .send
        V = Split(.responseText, C)
    End With
        On Error GoTo 0
        Munka1.Range("A2").Value = Split(V(1), , 2)
        'If IsArray(V) Then If UBound(V) > 0 Then MsgBox Split(V(1), , 2)(0), , C
End Sub

 

[Domenic]

After taking a quick look, probably . . .

If IsArray(V) Then If UBound(V) > 0 Then Munka1.Range("A2").Value = Split(V(1), , 2)(0)

 

[mikol]

After taking a quick look, probably . . .

If IsArray(V) Then If UBound(V) > 0 Then Munka1.Range("A2").Value = Split(V(1), , 2)(0)

Yes, thanks!