Netten veri çekme

[Tevfik_Kursun]

Günaydın Arkadaşlar,

Istanbul Bunker Prices

Latest Istanbul bunker prices, analysis, trends, and history.

shipandbunker.com

adresinden Adsız_1 resimdeki işaretli olan ilk sayıyı, A1 hücresine

Istanbul Bunker Prices

Latest Istanbul bunker prices, analysis, trends, and history.

shipandbunker.com

adresinden Adsız_2 resimdeki işaretli olan ilk sayıyı, A2 hücresine dosya her açıldığında getirmek istiyorum. Yardımcı olursanız sevinirim.
Saygılarılarımla

 

[Haluk]

1.resimdeki veri için aşağıdakikodu kullanın, 2. resimdeki verinin URL'ini bilmediğim için bir şey yapmadım, siz benzer şekilde yaparsınız...

Sub Get_Data()
    'Haluk - 18/03/2018
    
    Dim URL As String
    Dim objHTTP As Object, HTMLfile As Object
    
    URL = "https://shipandbunker.com/prices/emea/medabs/tr-ist-istanbul"
    
    Set objHTTP = CreateObject("MSXML2.XMLHTTP")
    objHTTP.Open "GET", URL, False
    objHTTP.Send
    
    Set HTMLfile = CreateObject("HTMLFILE")
    
    If objHTTP.ReadyState = 4 Then
        If objHTTP.Status = 403 Then
            MsgBox "Siteye erişiminiz engellenmiş .... Program sonlandırılacak !"
            GoTo SafeExit:
        End If
        If objHTTP.Status = 404 Then
            MsgBox "Sayfa bulunamadı .... Program sonlandırılacak !"
            GoTo SafeExit:
        End If
        If objHTTP.Status = 200 Then
            HTMLfile.Body.innerHTML = objHTTP.responseText
        End If
    End If
            
    Set Tables = HTMLfile.GetElementsByTagname("Table")
    
    Set myTable = Tables(1)
    
    Range("A1") = myTable.Rows(1).Cells(1).innerText
    
'    For i = 0 To myTable.Rows.Length - 1
'        iRow = iRow + 1
'
'        For j = 0 To myTable.Rows(i).Cells.Length - 1
'            Cells(iRow, j + 1) = myTable.Rows(i).Cells(j).innerText
'        Next
'    Next
        
SafeExit:
    Set objHTTP = Nothing
    Set HTMLfile = Nothing
End Sub

.

 

[Tevfik_Kursun]

Sayın Haluk Hocam,
İlginize çok teşekkür ederim. ORL ler aynı, ikincinin sonunda ek var. Hazırladığınız makroya bu eki ekleyip A2 ye yönlendirdim ama, yine aynı değeri getirdi.
"https://shipandbunker.com/prices/emea/medabs/tr-ist-istanbul"
"https://shipandbunker.com/prices/emea/medabs/tr-ist-istanbul#MGO"
Bakabiliirseniz makbule geçer.
Saygılarımla

 

[Haluk]

2. URL için;

Sub Get_Data2()
    'Haluk - 18/03/2018
   
    Dim URL As String
    Dim objHTTP As Object, HTMLfile As Object
   
    URL = "https://shipandbunker.com/prices/emea/medabs/tr-ist-istanbul#MGO"
   
    Set objHTTP = CreateObject("MSXML2.XMLHTTP")
    objHTTP.Open "GET", URL, False
    objHTTP.Send
   
    Set HTMLfile = CreateObject("HTMLFILE")
   
    If objHTTP.ReadyState = 4 Then
        If objHTTP.Status = 403 Then
            MsgBox "Siteye erişiminiz engellenmiş .... Program sonlandırılacak !"
            GoTo SafeExit:
        End If
        If objHTTP.Status = 404 Then
            MsgBox "Sayfa bulunamadı .... Program sonlandırılacak !"
            GoTo SafeExit:
        End If
        If objHTTP.Status = 200 Then
            HTMLfile.Body.innerHTML = objHTTP.responseText
        End If
    End If
           
    Set Tables = HTMLfile.GetElementsByTagname("Table")
   
    Set myTable = Tables(3)
   
    Range("A2") = myTable.Rows(1).Cells(1).innerText
   
'    For i = 0 To myTable.Rows.Length - 1
'        iRow = iRow + 1
'
'        For j = 0 To myTable.Rows(i).Cells.Length - 1
'            Cells(iRow, j + 1) = myTable.Rows(i).Cells(j).innerText
'        Next
'    Next
       
SafeExit:
    Set objHTTP = Nothing
    Set HTMLfile = Nothing
End Sub

.

 

[veyselemre]

    Set myTable = tables(1)
    Range("A1") = myTable.Rows(1).Cells(1).innerText
'bu satırın altına aşağıdaki satırı ekleyin.
    Range("A2") = tables(3).Rows(1).Cells(1).innerText

 

[Tevfik_Kursun]

Sayın Haluk Hocam,
İlginize ve zahmetlerinize çok teşekkür ederim.
Saygılarımla

 

[Tevfik_Kursun]

Sayın Veysel Emre Hocam,
İlginize çok teşekkür ederim.
Saygılarımla