• DİKKAT

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

VBA: web scrap ile veri çekme

A

a long time ago

Katılım
23 Şubat 2010
Mesajlar
90
Excel Vers. ve Dili
Excel 2007/ İngilizce
Merhaba,

Aşağıdaki websitesinden geçmiş dönem verilerini almak istiyorum. Ancak sitenin HTML kodu ile "click" eylemini ve tarih değiştirmeyi nasıl yapacağımı bir türlü çözemedim.

https://www.investing.com/equities/aksa-enerji-uretim-historical-data

Kod: 
Private Sub CommandButton1_Click() 
    Dim ws As Worksheet 
     
     
    Dim x As Single 
    Dim y As Single 
    Dim qt As QueryTable 
    Dim Url As String 
    Dim IE As Object 
    Dim frm As Object 
     
     
    Dim htmldoc As MSHTML.HTMLDocument 
    Dim htmlinput1 As MSHTML.IHTMLElement 
    Dim htmlbutton As MSHTML.IHTMLElement 
     
     
    For x = 1 To 100 
        Url = "url" & x 
        Url = Worksheets("Hyperlink List").Range("d" & x + 1) 
        Url = Url 
         
        Set IE = CreateObject("InternetExplorer.Application") 
        IE.navigate Url 
        IE.Visible = False 
         
        Do While IE.readystate <> readystate_complete 
        Loop 
        Set htmldoc = IE.document 
         
        Set htmlinput1 = htmldoc.getElementById("widgetFieldDateRange") 
        htmlinput1.innerText = "01/01/2012 - 04/10/2017" 
         
         
        Set htmlbutton = htmldoc.getElementById("applyBtn") 
        htmlbutton(1).submit 
         
         
         
        Set ws = Worksheets("Web_Queries") 
        y = x * 24 '(1330)
        Set qt = ws.QueryTables.Add(Connection:="URL;" & Url, Destination:=Worksheets("Web_Queries").Cells(y, 1)) 
        With qt 
            .WebFormatting = xlWebFormattingRTF 
            .WebSelectionType = xlSpecifiedTables 
            .WebTables = 3 
            .RefreshStyle = xlOverwriteCells 
            .BackgroundQuery = False 
            .Refresh 
        End With 
    Next 
     
     
    MsgBox "Process Completed" 
End Sub

Yardımcı olabilirseniz sevinirim.
 
Tablo sayfasında tarih aralığını ve link i girin.
Butona bastığınızda tablo excel e gelecektir.

http://dosya.co/8m0b56jf88f6/investing_bilgi_alma.xlsm.html

Kod: 
Dim link, tarih As String
Dim i As Long
Dim ie As Object
Dim objCollection As Object

Sub menu()
  Application.ScreenUpdating = False
  tarih = [B1]
  link = [F1]
  Call temizle
  Call url_ac
  Call verial
  
  Application.ScreenUpdating = True
  Sheets("Tablo").Select
End Sub

Sub url_ac()
  Set ie = CreateObject("InternetExplorer.Application")
  With ie
    .navigate link
    .Visible = 1
  End With
  Call bekle
End Sub

Sub verial()

' Web sayfasındaki tarih aralığına tarih bilgisi yazılıyor
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

Call bekle

'Tarih aralığı seçildikten sonraki Apply butonuna tıklanıyor.
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

Call bekle
'Tablo excel e aktarılıyor
Call tablo_getir

ie.Quit:
Set ie = Nothing
End Sub

Sub bekle()
    With ie
        Do Until .readyState = 4: DoEvents: Loop
        Do While .Busy: DoEvents: Loop
    End With
End Sub

Sub temizle()
    'Tablo sayfasındaki tablo bilgileri siliniyor
    Sheets("Tablo").Select
    Range("A3:G100000").ClearContents
    Selection.NumberFormat = "@"
    Range("A1").Select

End Sub


Sub tablo_getir()
Sheets("Tablo").Select
'ID si "curr_table" olan tablonun TD taglarındaki   text bilgileri alınıyor.
 Application.Wait Now + TimeValue("00:00:05")
Set objCollection = ie.document.getElementById("curr_table").getElementsByTagName("td")
i = 0
satir = 3
sutun = 1
Do While i < objCollection.Length
   'Table in TD tag ındaki text bilgisi excel e aktarılıyor.
   Cells(satir, sutun).Value = objCollection(i).innerText
   i = i + 1
   'Her 7 adet TD nin text bilgisi alındıktan sonra excel sayfasında bir satır artıyor ve kolon 1 olarak ayarlanıyor.
   'Alınacak tablo 10 kolon olsaydı buradaki 7 yi 10 olarak değiştirmemiz gerekirdi.
   If i Mod 7 = 0 Then
      sutun = 0
      satir = satir + 1
   End If
   sutun = sutun + 1
Loop

End Sub
 
Son düzenleme:
Yardım için teşekkürler. Kodu daha iyi anlamak için şunu sormak istiyorum:

Kod: 
Set objCollection = ie.document.getElementById("curr_table").getElementsByTagName("td")
ile mi tabloyu sayfadan çekiyoruz? kısaca açıklayabilirseniz memnun olurum.


asri' Alıntı:
Tablo sayfasında tarih aralığını ve link i girin.
Butona bastığınızda tablo excel e gelecektir.

http://dosya.co/8m0b56jf88f6/investing_bilgi_alma.xlsm.html

Kod: 
Dim link, tarih As String
Dim i As Long
Dim ie As Object
Dim objCollection As Object

Sub menu()
  Application.ScreenUpdating = False
  tarih = [B1]
  link = [F1]
  Call temizle
  Call url_ac
  Call verial
  
  Application.ScreenUpdating = True
  Sheets("Tablo").Select
End Sub

Sub url_ac()
  Set ie = CreateObject("InternetExplorer.Application")
  With ie
    .navigate link
    .Visible = 1
  End With
  Call bekle
End Sub

Sub verial()

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

Call bekle

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

Call bekle

Call tablo_getir

ie.Quit:
Set ie = Nothing
End Sub

Sub bekle()
    With ie
        Do Until .readyState = 4: DoEvents: Loop
        Do While .Busy: DoEvents: Loop
    End With
End Sub

Sub temizle()
    Sheets("Tablo").Select
    Range("A3:G100000").ClearContents
    Selection.NumberFormat = "@"
    Range("A1").Select

End Sub


Sub tablo_getir()
Sheets("Tablo").Select

Set objCollection = ie.document.getElementById("curr_table").getElementsByTagName("td")
i = 0
satir = 3
sutun = 1
Do While i < objCollection.Length

   Cells(satir, sutun).Value = objCollection(i).innerText
   i = i + 1

   If i Mod 7 = 0 Then
      sutun = 0
      satir = satir + 1
   End If
   sutun = sutun + 1
Loop

End Sub
Genişletmek için tıkla ...
 
a long time ago' Alıntı:
Yardım için teşekkürler. Kodu daha iyi anlamak için şunu sormak istiyorum:

Kod: 
Set objCollection = ie.document.getElementById("curr_table").getElementsByTagName("td")
ile mi tabloyu sayfadan çekiyoruz? kısaca açıklayabilirseniz memnun olurum.
Genişletmek için tıkla ...

Açıklamalar eklendi.
 
asri' Alıntı:
Açıklamalar eklendi.
Genişletmek için tıkla ...

Tekrar merhaba,

Kod: 
Set objCollection = ie.document.getElementById("curr_table").getElementsByTagName("td")

Kısmı için "Object required" hatası veriyor. Hiç bir değişiklik yapmadım da. Neden olabilir acaba?

Teşekkürler.
 
a long time ago' Alıntı:
Tekrar merhaba,

Kod: 
Set objCollection = ie.document.getElementById("curr_table").getElementsByTagName("td")
Kısmı için "Object required" hatası veriyor. Hiç bir değişiklik yapmadım da. Neden olabilir acaba?

Teşekkürler.
Genişletmek için tıkla ...

apply dedikten sonra tablo hemen gelmemiş olabilir.

Hemen öncesine aşağıdaki kod ekleyip deneyiniz.

Kod: 
 Application.Wait Now + TimeValue("00:00:05")
 
asri' Alıntı:
apply dedikten sonra tablo hemen gelmemiş olabilir.

Hemen öncesine aşağıdaki kod ekleyip deneyiniz.

Kod: 
 Application.Wait Now + TimeValue("00:00:05")
Genişletmek için tıkla ...

Süreyi 15sn'ye çıkardım ama yine de aynı hatayı veriyor.

İş yerinden bakıyorum şu an dün evden bakmıştım. İş yerindeki güvenlik sebebiyle olabilir mi?

Normalde Investing'i IE'de Inprivate olarak açıyorum . Acaba bir etkisi olabilir mi?

Teşekkürler.
 
a long time ago' Alıntı:
Süreyi 15sn'ye çıkardım ama yine de aynı hatayı veriyor.

İş yerinden bakıyorum şu an dün evden bakmıştım. İş yerindeki güvenlik sebebiyle olabilir mi?

Normalde Investing'i IE'de Inprivate olarak açıyorum . Acaba bir etkisi olabilir mi?

Teşekkürler.
Genişletmek için tıkla ...

Hata verilen satırın hemen öncesine Exit Sub ekleyin.
İşlemleri burada bitirmiş olun.

IE yi ve linkleri program açtığı için son duruma bakın hata vermeden önce Tablo gelmiş mi?

Eğer tablo geliyor ise ve hata veriyor ise kaynak kodlara bakmak lazım.
table ve td tagları ID ler düzgün mü?
 
Tek bir sorun kaldı. x=1'den 7'ye kadar olması gibi ilerliyor ama x=8 olduğu zaman kod ilerlemiyor.

Kodu kendimce ve amatörce biraz değiştirdim. Acaba x=8'den sonar ilerlemeye engel olan ne olabilir.

Kod: 
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

satir = 2
first = InputBox("Baslangic", , "03/09/2017")
second = InputBox("Bitis", , "03/11/2017")
tarih = first & " - " & second  'InputBox("Tarih girin", , "03/10/2017 - 04/11/2017")
firstdate = DateValue(first)
seconddate = DateValue(second)
n = DateDiff("d", firstdate, seconddate)

For x = 1 To 100
    'Loading bar
    Worksheets("Web_Queries").Range("m3").Value = x / 100
    c = 1
    Do While c <= n
        Worksheets("Web_Queries").Cells((x * n) + c - 1, 1).Value = Worksheets("Hyperlink List").Cells(x + 1, 3).Value
        c = c + 1
    Loop
        Url = "url" & x
    Url = Worksheets("Hyperlink List").Range("d" & x + 1)
    Url = Url
                
    Set ie = CreateObject("InternetExplorer.Application")
    ie.navigate Url
    ie.Visible = False
       
    
    With ie
        Do Until .readyState = 4: DoEvents: Loop
        Do While .Busy: DoEvents: Loop
    End With
       
    ' 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 Until .readyState = 4: DoEvents: Loop
        Do While .Busy: 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")
    y = (x * n) - x - 1
    '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
           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 7 = 0 Then
              sutun = 1
              satir = satir + 1
           End If
           sutun = sutun + 1
        Loop
        'satir = satir
Next

Worksheets("Web_Queries").Range("A:H").EntireColumn.AutoFit

MsgBox "Process Completed"

'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

Worksheets("Web_Queries").Range("m3").ClearContents

End Sub
 
a long time ago' Alıntı:
Tek bir sorun kaldı. x=1'den 7'ye kadar olması gibi ilerliyor ama x=8 olduğu zaman kod ilerlemiyor.

Kodu kendimce ve amatörce biraz değiştirdim. Acaba x=8'den sonar ilerlemeye engel olan ne olabilir.
Genişletmek için tıkla ...

Excel dosyanın linkini verebilir misiniz?
 
Next ten hemen önce aşağıdaki kodu ekleyin. Next dahil.

Kod: 
  ie.Quit:
  Set ie = Nothing
  Application.Wait Now + TimeValue("00:00:03")
Next
 
Şu şekilde sanırım?
...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
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 7 = 0 Then
sutun = 1
satir = satir + 1
End If
sutun = sutun + 1
Loop
'satir = satir
ie.Quit:
Set ie = Nothing
Application.Wait Now + TimeValue("00:00:03")
Next
Next
...
Genişletmek için tıkla ...
 
asri' Alıntı:
Next ten hemen önce aşağıdaki kodu ekleyin. Next dahil.

Kod: 
  ie.Quit:
  Set ie = Nothing
  Application.Wait Now + TimeValue("00:00:03")
Next
Genişletmek için tıkla ...

Arka arkaya 2 tane değil bir tane Next olacak sanırım. Yanlış yazdım bir önceki cevapta.

Paylaştığınız kodu ekleyerek denedim ama yine x=8'de donuyor.
 
Arka arkaya 2 tane değil bir tane Next olacak sanırım. Yanlış yazdım bir önceki cevapta.

Paylaştığınız kodu ekleyerek denedim ama yine x=8'de donuyor.
 
a long time ago' Alıntı:
Arka arkaya 2 tane değil bir tane Next olacak sanırım. Yanlış yazdım bir önceki cevapta.

Paylaştığınız kodu ekleyerek denedim ama yine x=8'de donuyor.
Genişletmek için tıkla ...

Aynı kodlar ile bende 30 link ciravı işlem yaptı bir sorun çıkarmadı.
Bağlantı hızı ile ilgili olabilir.

Başka pc ve başka internet bağlantıları ile deneyiniz.
 
asri' Alıntı:
Aynı kodlar ile bende 30 link ciravı işlem yaptı bir sorun çıkarmadı.
Bağlantı hızı ile ilgili olabilir.

Başka pc ve başka internet bağlantıları ile deneyiniz.
Genişletmek için tıkla ...

Akşam evden denedim. Hepsini alabildim ama bugün ofiste 8'de kaldı yine. Bir şekilde yine de tüm veriyi alabildiğim için sorun kalmadı.

Zamanınız için tekrar teşekkür ederim.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst