tefas.gov.tr' den veri çekme hk.

[pNouma]

Merhaba,

Aşağıdaki Kod ile TEFAS' dan fon bilgileirnden "Son 1 Ay Getirisi" değerini alabiliyoruz,
bunun gibi "Son Fiyat (TL)" değerini almak için kod üzerinde nasıl bir düzenleme yapmak gerekir?

c = ie.document.getElementsByTagName("span")(11).innerText

sanırsam saturunda bir düzenleme gerekecek


teşekkürler,
iyi çalışmalar.

Excel
Gorsel

Private Sub CommandButton1_Click()
Dim ie As InternetExplorer
Dim a As String
Dim c As Variant
Dim h As Integer
Dim j As Integer

j = ActiveSheet.Range("A2").End(xlDown).Row
On Error Resume Next
For h = 2 To j
    Set ie = CreateObject("internetexplorer.application")
    a = ActiveSheet.Range("A" & h).Value
    ie.navigate "https://www.tefas.gov.tr/FonAnaliz.aspx?FonKod=" & a
    ie.Visible = False
    
    Do While ie.readyState <> 4
        DoEvents
    Loop
    c = ie.document.getElementsByTagName("span")(11).innerText
    
    Worksheets("Sayfa1").Cells(h, 2) = c
    
    ie.Quit

Set ie = Nothing
Next h

End Sub

 

[halit3]

kod

Private Sub CommandButton1_Click()
Dim ie As InternetExplorer
Dim a As String
Dim c As Variant
Dim h As Integer
Dim j As Integer

j = ActiveSheet.Range("A2").End(xlDown).Row
'On Error Resume Next

  Set ie = CreateObject("internetexplorer.application")

ie.navigate "https://www.tefas.gov.tr/FonAnaliz.aspx?FonKod="
    ie.Visible = True

For h = 2 To j
 
    a = ActiveSheet.Range("A" & h).Value
    ie.navigate "https://www.tefas.gov.tr/FonAnaliz.aspx?FonKod=" & a

    
    Do While ie.readyState <> 4
        DoEvents
    Loop
    c = ie.document.getElementsByTagName("span")(3).innerText

    Worksheets("Sayfa1").Cells(h, 2) = c

Next h
 ie.Quit
 Set ie = Nothing
  
End Sub

 

[pNouma]

Teşekkürler Halit Hocam,

bir şey daha sorabilir miyim?

https://www.tefas.gov.tr/FonKarsilastirma.aspx

linkinde yer alan Excel butonuna tıklayarak excel dosyası olarak indirebiliyoruz,
Burada indirilen excel dosyasındaki verileri aktif sayfa içine almamız mümkün müdür?

iyi çalışamalar

 

[halit3]

Ana dosyaya bu kodu ekleyiniz.
kodu çalıştırdığınızda daha önce indirilen dosyayı bulun ve tamam tıklayın.

Sub veri_getir1()
zaman = Time
Syf1 = ActiveSheet.Name
Dosya = Application.GetOpenFilename("Excel dosyalrı(*.xls*),*.xls*")
If Dosya = False Then Exit Sub
ThisWorkbook.Sheets(Syf1).Columns("A:J").ClearContents
Sayfa_adı = "Sheet1"
Dim fL As Object
Set fL = CreateObject("Scripting.FileSystemObject")
Set Kayit = CreateObject("ADODB.recordset")
baglan = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & Dosya & ";Extended Properties=""Excel 12.0;HDR=yes;IMEX=1;"""
Kayit.Open "Select * from [" & Sayfa_adı & "$] ;", baglan, 1, 1
ThisWorkbook.Sheets(Syf1).Range("A1").CopyFromRecordset Kayit
Kayit.Close
Set Kayit = Nothing
MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & _
"İşlem süresi ; " & Format(Time - zaman, "hh:nn:ss")
End Sub

 

[pNouma]

Ana dosyaya bu kodu ekleyiniz.
kodu çalıştırdığınızda daha önce indirilen dosyayı bulun ve tamam tıklayın.

Sub veri_getir1()
zaman = Time
Syf1 = ActiveSheet.Name
Dosya = Application.GetOpenFilename("Excel dosyalrı(*.xls*),*.xls*")
If Dosya = False Then Exit Sub
ThisWorkbook.Sheets(Syf1).Columns("A:J").ClearContents
Sayfa_adı = "Sheet1"
Dim fL As Object
Set fL = CreateObject("Scripting.FileSystemObject")
Set Kayit = CreateObject("ADODB.recordset")
baglan = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & Dosya & ";Extended Properties=""Excel 12.0;HDR=yes;IMEX=1;"""
Kayit.Open "Select * from [" & Sayfa_adı & "$] ;", baglan, 1, 1
ThisWorkbook.Sheets(Syf1).Range("A1").CopyFromRecordset Kayit
Kayit.Close
Set Kayit = Nothing
MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & _
"İşlem süresi ; " & Format(Time - zaman, "hh:nn:ss")
End Sub

Çok Teşekkür ederim Halit Hocam
iyi ki varsınız!

 

[huzur2172]

Ana dosyaya bu kodu ekleyiniz.
kodu çalıştırdığınızda daha önce indirilen dosyayı bulun ve tamam tıklayın.

Sub veri_getir1()
zaman = Time
Syf1 = ActiveSheet.Name
Dosya = Application.GetOpenFilename("Excel dosyalrı(*.xls*),*.xls*")
If Dosya = False Then Exit Sub
ThisWorkbook.Sheets(Syf1).Columns("A:J").ClearContents
Sayfa_adı = "Sheet1"
Dim fL As Object
Set fL = CreateObject("Scripting.FileSystemObject")
Set Kayit = CreateObject("ADODB.recordset")
baglan = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & Dosya & ";Extended Properties=""Excel 12.0;HDR=yes;IMEX=1;"""
Kayit.Open "Select * from [" & Sayfa_adı & "$] ;", baglan, 1, 1
ThisWorkbook.Sheets(Syf1).Range("A1").CopyFromRecordset Kayit
Kayit.Close
Set Kayit = Nothing
MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & _
"İşlem süresi ; " & Format(Time - zaman, "hh:nn:ss")
End Sub

Merhaba hocam. Öncelikle yukarıdaki dosya indirme bağlantısını bizimle paylaştığınız için teşekkür ederiz. xlsm uzantılı excel dosyasını indirdiğimde kod gayet güzel çalışmakta; ancak benim ihtiyacım olan kod vba kodu değil de google e-tablolarda aynı işlevde kullanmak üzere apps script kodu. Yani istediğim şey aşağıdaki kodların apps script versiyonu.
Private Sub CommandButton1_Click()
Dim ie As InternetExplorer
Dim a As String
Dim c As Variant
Dim h As Integer
Dim j As Integer

j = ActiveSheet.Range("A2").End(xlDown).Row
On Error Resume Next
For h = 2 To j
Set ie = CreateObject("internetexplorer.application")
a = ActiveSheet.Range("A" & h).Value
ie.navigate "https://www.tefas.gov.tr/FonAnaliz.aspx?FonKod=" & a
ie.Visible = False

Do While ie.readyState <> 4
DoEvents
Loop
c = ie.document.getElementsByTagName("span")(7).innerText

Worksheets("Sayfa1").Cells(h, 2) = c

ie.Quit

Set ie = Nothing
Next h

End Sub

Konu hakkında yardımcı olursanız mutlu olurum. Şimdiden teşekkürler.