• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Soru Ziraat katılım bankasından altın alış ve satış verilerini excele çekme

okan32

okan32

Altın Üye
Katılım
12 Mayıs 2016
Mesajlar
386
Excel Vers. ve Dili
Ofis 2019- 32 Bit - Türkçe
Altın Üyelik Bitiş Tarihi
16-04-2026
Aşağıdaki kod ile ziraat katılım bankasından altın alış ve satış verilerini excele çekiyordum ama dünden bu tarafa hata veriyor. yardımlarınız için şimdiden çok teşekkürler.

Kod: 
Sub AltinVeriAl()
'This will load a webpage in IE
    Dim i As Long
    Dim URL As String
    Dim IE As Object
    Dim objElement As Object
    Dim objCollection As Object
    'Create InternetExplorer Object
    Worksheets("Sayfa1").Unprotect "2713233"
Range("H2") = Format(Now, "dd.mm.yyyy hh:mm")
    Set IE = CreateObject("InternetExplorer.Application")
    'Set IE.Visible = True to make IE visible, or False for IE to run in the background
    IE.Visible = False
    'Define URL
    URL = "https://www.ziraatkatilim.com.tr/"
    'Navigate to URL
    IE.Navigate URL
    ' Statusbar let's user know website is loading
    Application.StatusBar = URL & " is loading. Please wait..."
    ' Wait while IE loading...
    'IE ReadyState = 4 signifies the webpage has loaded (the first loop is set to avoid inadvertently skipping over the second loop)
    Do While IE.ReadyState = 4: DoEvents: Loop   'Do While
    Do Until IE.ReadyState = 4: DoEvents: Loop   'Do Until
    'Webpage Loaded
    Application.StatusBar = URL & " Loaded"
    Application.Wait (Now + TimeValue("0:00:05"))
   ActiveSheet.Range("r1") = IE.document.getelementbyid("piyasalar").innertext
    'Unload IE
    IE.Quit
    Set IE = Nothing
    Set objElement = Nothing
    Set objCollection = Nothing
    'MsgBox "Veriler çekildi."
    Range("G2").Value = Range("J2").Value
    Range("G3").Value = Range("J3").Value
    Range("G4").Value = Range("J4").Value
    Range("G5").Value = Range("J5").Value
    UserForm1.Show 'ana kod bloğuna geçerken bu satır aktif edilmeli
    Worksheets("Sayfa1").Protect "2713233"
    
End Sub
 
H

Haluk

Özel Üye
Katılım
7 Temmuz 2004
Mesajlar
12,398
Excel Vers. ve Dili
64 Bit 2010 - İngilizce
+
Google Sheets
+
JScript
Altın Üyelik Bitiş Tarihi
∞
Ekli dosyayı kullanabilirsiniz...

.
 

Ekli dosyalar

H

Haluk

Özel Üye
Katılım
7 Temmuz 2004
Mesajlar
12,398
Excel Vers. ve Dili
64 Bit 2010 - İngilizce
+
Google Sheets
+
JScript
Altın Üyelik Bitiş Tarihi
∞
Eğer sizin istediğiniz sadece altın alış ve satış fiyatlarıysa, o zaman aşağıdaki kodu deneyin.

Ben sonuçları MsgBox ile gösterdim, siz istediğiniz hücreye yazdırabilirsiniz....

C#: 
Sub GetAltin()
    ' Haluk - 14/05/2020
    '
    Dim objHTTP As Object, strURL As String, HTMLcode As String
    Dim regExp As Object, valDoviz As Variant
    
    Set objHTTP = CreateObject("MSXML2.XMLHTTP")
    
    strURL = "https://www.ziraatkatilim.com.tr/ajax/piyasalar.php"
    
    objHTTP.Open "GET", strURL, False
    objHTTP.setRequestHeader "If-None-Match", "\zoru-basaririz-imkansiz-biraz-zaman-alir\"
    objHTTP.send
    
    If objHTTP.Status = 200 Then
        HTMLcode = objHTTP.responseText
        
        Set regExp = CreateObject("VBScript.RegExp")
        regExp.ignorecase = True
        regExp.Global = True
        regExp.Pattern = """code"":""XAU"",""rate"":(.+?),""diff"":(.+?),""buy"":""(.+?)"",""sell"":""(.+?)"""
        
        Set RetVal = regExp.Execute(HTMLcode)
        
        altinALIS = RetVal(0).SubMatches(2) + 0
        altinSATIS = RetVal(0).SubMatches(3) + 0
                
        MsgBox altinALIS
        MsgBox altinSATIS
   
    ElseIf objHTTP.Status = 429 Then
        MsgBox "Sunucuya çok fazla istek yollandý, bir süre dinlenin....!"
    ElseIf objHTTP.Status = 503 Then
        MsgBox "Sunucuda bakým var, bir süre sonra tekrar deneyin....!"
    Else
        MsgBox "Sunucudan alýnan hata mesajý :" & vbCrLf & vbCrLf & _
               "Kod :" & objHTTP.Status & vbCrLf & vbCrLf & _
               objHTTP.Statustext
    End If
    
    Set regExp = Nothing
    Set objHTTP = Nothing
End Sub
.
 
Son düzenleme:
okan32

okan32

Altın Üye
Katılım
12 Mayıs 2016
Mesajlar
386
Excel Vers. ve Dili
Ofis 2019- 32 Bit - Türkçe
Altın Üyelik Bitiş Tarihi
16-04-2026
Haluk' Alıntı:
Eğer sizin istediğiniz sadece altın alış ve satış fiyatlarıysa, o zaman aşağıdaki kodu deneyin.

Ben sonuçları MsgBox ile gösterdim, siz istediğiniz hücreye yazdırabilirsiniz....

C#: 
Sub GetData2()
    ' Haluk - 14/05/2020
    '
    Dim objHTTP As Object, strURL As String, HTMLcode As String
    Dim regExp As Object, valDoviz As Variant
  
    Set objHTTP = CreateObject("MSXML2.XMLHTTP")
  
    strURL = "https://www.ziraatkatilim.com.tr/ajax/piyasalar.php"
  
    objHTTP.Open "GET", strURL, False
    objHTTP.setRequestHeader "If-None-Match", "\zoru-basaririz-imkansiz-biraz-zaman-alir\"
    objHTTP.send
  
    If objHTTP.Status = 200 Then
        HTMLcode = objHTTP.responseText
      
        Set regExp = CreateObject("VBScript.RegExp")
      
        regExp.ignorecase = True
        regExp.Global = True
        regExp.Pattern = """code"":""XAU"",""rate"":(.+?),""diff"":false,""buy"":""(.+?)"",""sell"":""(.+?)"""
      
        Set RetVal = regExp.Execute(HTMLcode)
      
        altinALIS = RetVal(0).SubMatches(1) + 0
        altinSATIS = RetVal(0).SubMatches(2) + 0
           
        MsgBox altinALIS
        MsgBox altinSATIS
 
    ElseIf objHTTP.Status = 429 Then
        MsgBox "Sunucuya çok fazla istek yollandý, bir süre dinlenin....!"
    ElseIf objHTTP.Status = 503 Then
        MsgBox "Sunucuda bakým var, bir süre sonra tekrar deneyin....!"
    Else
        MsgBox "Sunucudan alýnan hata mesajý :" & vbCrLf & vbCrLf & _
               "Kod :" & objHTTP.Status & vbCrLf & vbCrLf & _
               objHTTP.Statustext
    End If
  
    Set regExp = Nothing
    Set objHTTP = Nothing
End Sub
.
Genişletmek için tıkla ...
Tamam hocam teşekkürler
 
okan32

okan32

Altın Üye
Katılım
12 Mayıs 2016
Mesajlar
386
Excel Vers. ve Dili
Ofis 2019- 32 Bit - Türkçe
Altın Üyelik Bitiş Tarihi
16-04-2026
Haluk' Alıntı:
Eğer sizin istediğiniz sadece altın alış ve satış fiyatlarıysa, o zaman aşağıdaki kodu deneyin.

Ben sonuçları MsgBox ile gösterdim, siz istediğiniz hücreye yazdırabilirsiniz....

C#: 
Sub GetData2()
    ' Haluk - 14/05/2020
    '
    Dim objHTTP As Object, strURL As String, HTMLcode As String
    Dim regExp As Object, valDoviz As Variant
  
    Set objHTTP = CreateObject("MSXML2.XMLHTTP")
  
    strURL = "https://www.ziraatkatilim.com.tr/ajax/piyasalar.php"
  
    objHTTP.Open "GET", strURL, False
    objHTTP.setRequestHeader "If-None-Match", "\zoru-basaririz-imkansiz-biraz-zaman-alir\"
    objHTTP.send
  
    If objHTTP.Status = 200 Then
        HTMLcode = objHTTP.responseText
      
        Set regExp = CreateObject("VBScript.RegExp")
      
        regExp.ignorecase = True
        regExp.Global = True
        regExp.Pattern = """code"":""XAU"",""rate"":(.+?),""diff"":false,""buy"":""(.+?)"",""sell"":""(.+?)"""
      
        Set RetVal = regExp.Execute(HTMLcode)
      
        altinALIS = RetVal(0).SubMatches(1) + 0
        altinSATIS = RetVal(0).SubMatches(2) + 0
           
        MsgBox altinALIS
        MsgBox altinSATIS
 
    ElseIf objHTTP.Status = 429 Then
        MsgBox "Sunucuya çok fazla istek yollandý, bir süre dinlenin....!"
    ElseIf objHTTP.Status = 503 Then
        MsgBox "Sunucuda bakým var, bir süre sonra tekrar deneyin....!"
    Else
        MsgBox "Sunucudan alýnan hata mesajý :" & vbCrLf & vbCrLf & _
               "Kod :" & objHTTP.Status & vbCrLf & vbCrLf & _
               objHTTP.Statustext
    End If
  
    Set regExp = Nothing
    Set objHTTP = Nothing
End Sub
.
Genişletmek için tıkla ...
Haluk hocam ekran görüntüsündeki satırda hata verdi
 

Ekli dosyalar

H

Haluk

Özel Üye
Katılım
7 Temmuz 2004
Mesajlar
12,398
Excel Vers. ve Dili
64 Bit 2010 - İngilizce
+
Google Sheets
+
JScript
Altın Üyelik Bitiş Tarihi
∞
5 No'lu mesajdaki kodu revize ettim, onu kullanın...

.
 
Son düzenleme:
Cevap yazmak için giriş yap yada kayıt ol.
Üst