Internetten veri çekme ve Do while döngüsü

[a long time ago]

Merhaba,

Aşağıda gördüğünüz kodu geçen haftaya kadar kullanabiliyorken, bir haftadır ilgili siteden veri gelmiyor ya da ara sıra geliyor, kod hata da vermiyor. Fakat kodun aşağıda işaretli kısımda takıldığını görüyorum.

Veri çektiğim site ise: https://www.investing.com/currencies/usd-try-historical-data

Bu siteden kurları çektiriyorum.

Biraz araştırdım ama neticeye ulaşamadım. Acaba siteden veri alması neden düzensiz çözemedim. Yardımcı olursanız memnun olurum. Kod acemice yazılmıştır.

Sub CommandButton1_Click()
Dim ws As Worksheet
Dim x As Single
Dim y As Single
Dim n As Single
Dim Url As String
Dim tarih As String, first As Date, second As Date
Dim i As Long
Dim ie As Object
Dim objCollection As Object
Dim StartTime As Double
Dim MinutesElapsed As String

'Remember time when macro starts
'StartTime = Timer
Worksheets("Web_Queries").Range("a2:g200000").ClearContents
first = InputBox("Baslangic", , "04/12/2017")
second = InputBox("Bitis", , "04/13/2017")
tarih = first & " - " & second

satir = 2
c = 1
For x = 1 To 21
    'Loading bar
    Worksheets("Web_Queries").Range("l3").Value = x / 21
    
    Url = "url" & x
    Url = Worksheets("Hyperlink List").Range("d" & x + 1)
    Url = Url
                
    Set ie = CreateObject("InternetExplorer.Application")
    ie.navigate Url
    ie.Visible = False
       
    
    [COLOR="Red"]With ie
        Do While .Busy: DoEvents: Loop
        Do Until .readyState = 4: DoEvents: Loop
    End With[/COLOR]       
    ' Web sayfasindaki tarih araligina tarih bilgisi yaziliyor
    Set objCollection = ie.document.getElementsByTagName("input")
    i = 0
    Do While i < objCollection.Length
       If objCollection(i).ID = "picker" Then
          objCollection(i).Value = tarih
          objCollection(i).Click
          Exit Do
        End If
        i = i + 1
    Loop
        
    With ie
        Do While .Busy: DoEvents: Loop
        Do Until .readyState = 4: DoEvents: Loop
    End With

    'Tarih araligi seçildikten sonraki Apply butonuna tiklaniyor.
    Set objCollection = ie.document.getElementsByTagName("a")
    i = 0
    Do While i < objCollection.Length
       If objCollection(i).ID = "applyBtn" Then
          objCollection(i).Click
          Exit Do
        End If
        i = i + 1
    Loop
    Application.Wait Now + TimeValue("00:00:05")
    
    
    With ie
        Do Until .readyState = 4: DoEvents: Loop
        Do While .Busy: DoEvents: Loop
    End With
           

    Set ws = Worksheets("Web_Queries")
   
   'Tablo excel e aktariliyor
    Set objCollection = ie.document.getElementById("curr_table").getElementsByTagName("td")
    i = 0
    sutun = 2

    Do While i < objCollection.Length
        'Table in TD tag indaki text bilgisi excel e aktariliyor.
        Worksheets("Web_Queries").Cells(satir, sutun).Value = objCollection(i).innerText
        Worksheets("Web_Queries").Cells(satir, 1) = Worksheets("Hyperlink List").Cells(x + 1, 3).Value
        i = i + 1
        'Her 7 adet TD nin text bilgisi alindiktan sonra excel sayfasinda bir satir artiyor ve kolon 1 olarak ayarlaniyor.
        'Alinacak tablo 10 kolon olsaydi buradaki 7 yi 10 olarak degistirmemiz gerekirdi.
        If i Mod 6 = 0 Then
            sutun = 1
            satir = satir + 1
        End If
            sutun = sutun + 1
        Loop
        
       
ie.Quit:
Set ie = Nothing
Application.Wait Now + TimeValue("00:00:03")
Next

'Determine how many seconds code took to run
  'MinutesElapsed = Format((Timer - StartTime) / 86400, "hh:mm:ss")
'Notify user in seconds
  'MsgBox "This code ran successfully in " & MinutesElapsed & " minutes", vbInformation

If Worksheets("Archive").Range("A2").Value = vbNullString Then
    aa = Worksheets("Web_Queries").Range("a:a").End(xlDown).Row
    Set satir = Worksheets("Web_Queries").Range("a2")
    Worksheets("Web_Queries").Range(satir.Address & ":" & "g" & (aa)).Copy
    Worksheets("Archive").Paste Destination:=Worksheets("Archive").Range("A2" & ":" & "g" & (aa))
    Worksheets("Web_Queries").Range("A:G").EntireColumn.AutoFit
Else
    Call yeniveriekle
End If

Worksheets("Web_Queries").Range("A:G").EntireColumn.AutoFit
MsgBox "Process Completed"

End Sub

 

[askm]

İnternet sitesinin tam yüklenmesini bekliyor kod burada. Bunun yerine bekleme kodu ekleyebilirsiniz.Aşağıda 5 sn bekleme kodu mevcut. Sayfaya göre bunu artırabilirsiniz.

 Application.Wait Now + TimeValue("00:00:05")

 

[a long time ago]

Çok teşekkürler. Sorun çözüldü.

İnternet sitesinin tam yüklenmesini bekliyor kod burada. Bunun yerine bekleme kodu ekleyebilirsiniz.Aşağıda 5 sn bekleme kodu mevcut. Sayfaya göre bunu artırabilirsiniz.

 Application.Wait Now + TimeValue("00:00:05")