İnternetten Veri Alma

[mekist]

@Haluk Bey

Çok teşekkür ederim

Son bir sorum olabilir mi

Temettüler için tablo üzerinden alıyoruz, Her şirket için tablo numarası farklı olduğu için tablo bölümünü değişken yaptım buraya kadar sorun yok
500' den fazla şirket olması nedeniyle her şirketin hangi tablodan veri geldiğini deneme yanılma yöntemiyle buluyorum, temettüler için aşağıdaki gibi html tablosu da yok sanırım, baktığımda sayfa kod bölümünde göremedim
Şirket tablo eşleştirmesi görebileceğim bir yer var mıdır

Eğer yine yanlış anlamadıysam, aradığınız veriler bu kodla alınabiliyor......

Sub Test3()
'   Haluk - 30/06/2024
   
    Dim xmlHTTPReq As Object
    Dim HTMLdoc As Object
    Dim strURL As String
    Dim noRows As Integer, i As Integer, j As Integer
   
    Set xmlHTTPReq = CreateObject("MSXML2.XMLHTTP.6.0")
    Set HTMLdoc = CreateObject("HTMLFILE")

    strURL = "https://www.isyatirim.com.tr/tr-tr/analiz/hisse/Sayfalar/sirket-karti.aspx?hisse=ADEL"
    xmlHTTPReq.Open "GET", strURL, False
    xmlHTTPReq.send
  
    If xmlHTTPReq.Status = 200 Then
        Range("A1:H" & Rows.Count) = ""
        HTMLdoc.body.innerHTML = xmlHTTPReq.responseText
        HTMLdoc.Close
       
        Set Tables = HTMLdoc.getElementsByTagName("tbody")
        Set myTable = Tables(12)

        noRows = myTable.Rows.Length
       
        For j = 0 To myTable.Rows(0).Cells.Length - 1
            If j >= 2 And j < 7 Then
                Cells(1, j + 1) = Tables(11).Rows(i).Cells(j).innerText + 0
            Else
                Cells(1, j + 1) = Tables(11).Rows(i).Cells(j).innerText
            End If
        Next
       
        For i = 0 To noRows - 1
            For j = 0 To myTable.Rows(i).Cells.Length - 1
                If j >= 2 And j < 7 Then
                    Cells(i + 2, j + 1) = myTable.Rows(i).Cells(j).innerText + 0
                Else
                    Cells(i + 2, j + 1) = myTable.Rows(i).Cells(j).innerText
                End If
            Next
        Next
    End If
   
    Set Tables = Nothing
    Set myTable = Nothing
    Set HTMLdoc = Nothing
    Set xmlHTTPReq = Nothing
End Sub

.

 

[Haluk]

Alıntı yaptığınız mesajda; strURL değişkeninde hisse=ADEL yerine hisse=ALGYO yazınca, ilgili şirketin verileri gelmiyor mu?

.

 

[mekist]

Buradaki tabloları her şirket için farklı olabiliyor, bir çok şirkette aynı olmasına rağmen tablo sayıları fazla olan şirketlerde aynı tabloyla farklı veri geliyor
Şirket bazında aşağıdaki tablolarla veriler geliyor

        Set myTable = Tables(12)

        noRows = myTable.Rows.Length
       
        For j = 0 To myTable.Rows(0).Cells.Length - 1
            If j >= 2 And j < 7 Then
                Cells(1, j + 1) = Tables(11).Rows(i).Cells(j).innerText + 0
            Else
                Cells(1, j + 1) = Tables(11).Rows(i).Cells(j).innerText
            End If

 

[Haluk]

Tabloların ClassName'lerini kullanmak daha mantıklı çözüm olabilir....

Aşağıdaki kodda hisse adını değiştirerek deneme yaparsınız...

Sub Test7()
'   Haluk - 07/07/2024
  
    Dim xmlHTTPReq As Object
    Dim HTMLdoc As Object
    Dim strURL As String
    Dim noRows As Integer, i As Integer, j As Integer
  
    Set xmlHTTPReq = CreateObject("MSXML2.XMLHTTP.6.0")
    Set HTMLdoc = CreateObject("HTMLFILE")

    strURL = "https://www.isyatirim.com.tr/tr-tr/analiz/hisse/Sayfalar/sirket-karti.aspx?hisse=SASA"
    xmlHTTPReq.Open "GET", strURL, False
    xmlHTTPReq.send
 
    If xmlHTTPReq.Status = 200 Then
        Range("A1:H" & Rows.Count) = ""
        HTMLdoc.body.innerHTML = xmlHTTPReq.responseText
        HTMLdoc.Close
      
        Set Tables = HTMLdoc.getElementsByTagName("tbody")
        
        For i = 0 To Tables.Length
            If Tables(i).className = "temettugercekvarBody hepsi" Then
                Set myTable = Tables(i)
                Exit For
            End If
        Next

        noRows = myTable.Rows.Length
              
        For i = 0 To noRows - 1
            For j = 0 To myTable.Rows(i).Cells.Length - 1
                If j >= 2 And j < 7 Then
                    Cells(i + 2, j + 1) = myTable.Rows(i).Cells(j).innerText + 0
                Else
                    Cells(i + 2, j + 1) = myTable.Rows(i).Cells(j).innerText
                End If
            Next
        Next
    End If
  
    Set Tables = Nothing
    Set myTable = Nothing
    Set HTMLdoc = Nothing
    Set xmlHTTPReq = Nothing
End Sub

.

 

[mekist]

oldu teşekkür ederim
Hakkınızı helal edin

 

[Haluk]

Eyvallah, helal olsun...

.

 

[Haluk]

Temettu için revize bir dosya ekledim..... Hisse kodunu sayfadaki açılır kutudan seçebiliyorsunuz, seçilen koda ait şirket adı da aşağısandaki hücrede yazar. Açılır listedeki veriler, dosyanın açılışında internet bağlantısıyla İş Yatırım'dan alınır.

.

 

[mekist]

teşekkür ederim
bende ekteki dosyada sizin yardımınızla istenen şirkete ait verileri ekteki dosyaya anlık çektiriyorum
Şirkete ait verileri 15 - 20 saniye aralığında çekiyor

1. Temettü
2. Yabancı Oranı
3. 10 yıllık hacimli Fiyat
4. 10 yıllık mali tablolar
5. Rasyolar

 

[Haluk]

Dosyayı kapatıp başka bir Excel dosyası açınca formül çubuğu görünmüyor...... hoş bir durum değil. Ayrıca, VBA kodu şifreli olduğundan inceleyemedim. Şifreyi kırmaya da üşendim....

.

 

[mekist]

Formül çubuğunun açılmasını yapamamamıştım

Dosayayı gönderdiğim kullanıcılar sistemi bozmasınlsr diye şifrelemiştim
Sifresini size gönderdim

 

[Haluk]

Formül çubuğunun açılmasını yapamamamıştım
......
....

Dosyanın kapanış olayına aşağıdakini yazarsınız...

    Application.DisplayFormulaBar = True

.

 

[mekist]

kaydetmek istiyor musunuz sorusunu sormasın diye düzenleme yapmıştım
kodun ilk kısmına ekledim, artık sonra açılan dosyalarda formül çubuğu gizlenmiyor

teşekkür ederim

 

[ÖmerBey]

kaydetmek istiyor musunuz sorusunu sormasın diye düzenleme yapmıştım

Merhaba,
Konudan bağımsız olarak Application.DisplayFormulaBar ile Application.DisplayAlerts karışmış olabilir mi?

 

[mekist]

Merhaba,
Konudan bağımsız olarak Application.DisplayFormulaBar ile Application.DisplayAlerts karışmış olabilir mi?

Ömer Bey

Dosyanın kaydetmeden çıkması için aşağıdak, kodları kullanıyorum
Application.DisplayFormulaBar çıkışta formül çubuğunu tekrar açması için kullanıyorum

Sub Kayıt_Etmeden_Cıkma()
Application.DisplayFormulaBar = True
ActiveWorkbook.Saved = True
Application.Quit
End Sub

 

[ÖmerBey]

Şimdi anladım, hata bendeymiş.
Öncesinde Application.DisplayAlerts = False komutu kullanarak yapılan uyarıları engelleme işlemi hakkında yazdığınızı zannedip dahil olmuştum.
İyi çalışmalar diliyorum...