Web'den Döviz Bilgilerini Alma Otomatik

[Ergün Güler]

Merhaba,

Ergün bey dikkat ettiyseniz Halit beyin önerdiği kodda aşağıdaki satırda "add" ifadesi kullanılmış.

With ActiveSheet.QueryTables.[COLOR=red]Add[/COLOR]

Bu ifade ekle anlamına gelmektedir. Siz kodu her çalıştırdığınızda sayfaya otomatikman yeni bir "QueryTable" eklenmektedir. Bu sebeple veri alımından önce sayfadaki alanı silmek gerekecektir. bu şekilde birden fazla "QueryTable" oluşması engellenmiş olacaktır.

Korhan Bey,
İlginiz için çok teşekkür ederim. anladım. her kod çalıştığında "table" ekliyor. şöyle birşey deneyeyim dedim;
tables'in "name"ini ="tablo" yaptım. kodlar çalıştığında, "tablo" adında tablo var ise, "add" kodlarını atlasın diye pek de berecemedim.

 

[Ergün Güler]

Koddaki aşağıdaki bölümün hemen üstüne eklenmek üzere

Application.OnTime Now + TimeValue("00:00:05"), "Auto_Open"

bunu ekleyin

Dim qt As QueryTable
For Each qt In Sheets("KURLAR").QueryTables
qt.Delete
Next qt

Çok teşekkür ederim. çok faydalı oldu.
Başka bir soru daha sorabilir miyim?
kur bilgilerini direkt Userform'daki Textbox'lara almanın mümkünü yok mudur?

 

[halit3]

Çok teşekkür ederim. çok faydalı oldu.
Başka bir soru daha sorabilir miyim?
kur bilgilerini direkt Userform'daki Textbox'lara almanın mümkünü yok mudur?

Userforma sadece bir adet label9 nesnesi ekleyin

kod:

Dim sayac
Private Declare Function InternetCheckConnection Lib "wininet.dll" Alias "InternetCheckConnectionA" (ByVal lpszUrl As String, ByVal dwFlags As Long, ByVal dwReserved As Long) As Long
Sub Auto_Open()
If (InternetCheckConnection("[URL]http://www.tcmb.gov.tr/yeni/tablolar.php/[/URL]", &H1, 0&) = 0) Then
'URL = "[URL]http://www.tcmb.gov.tr/yeni/tablolar.php[/URL]"
MsgBox "Bağlantı Yok"
Else
Application.OnTime Now + TimeValue("00:00:05"), "devamet"
End If
  'MsgBox "güncelleniyor..."
End Sub
Sub devamet()
Application.ScreenUpdating = False
sayac = sayac + 1
say1 = UserForm1.TextBox1
say2 = UserForm1.TextBox2
say3 = UserForm1.TextBox3
say4 = UserForm1.TextBox4
say5 = UserForm1.TextBox5
Dim URL As String
Dim HTML_Body As Object
Dim IE As Object
URL = "[URL]http://www.tcmb.gov.tr/yeni/tablolar.php[/URL]"
sat = 1
Set IE = CreateObject("InternetExplorer.Application")
With IE
.Navigate URL
.Visible = False
Do Until IE.ReadyState = 4: DoEvents: Loop
Do While IE.Busy: DoEvents: Loop
Do Until IE.ReadyState = 4: DoEvents: Loop
On Error Resume Next
'MsgBox IE.document.GetElementsByTagName("TABLE").Item(3).Rows(1).Cells(1).InnerText
'MsgBox IE.document.GetElementsByTagName("TABLE").Item(3).Rows(1).Cells(2).InnerText
'MsgBox IE.document.GetElementsByTagName("TABLE").Item(3).Rows(2).Cells(0).InnerText
UserForm1.TextBox1 = IE.document.GetElementsByTagName("TABLE").Item(3).Rows(2).Cells(1).InnerText
UserForm1.TextBox2 = IE.document.GetElementsByTagName("TABLE").Item(3).Rows(2).Cells(2).InnerText
'MsgBox IE.document.GetElementsByTagName("TABLE").Item(3).Rows(3).Cells(0).InnerText

UserForm1.TextBox3 = IE.document.GetElementsByTagName("TABLE").Item(3).Rows(3).Cells(1).InnerText
UserForm1.TextBox4 = IE.document.GetElementsByTagName("TABLE").Item(3).Rows(3).Cells(2).InnerText

IE.Quit
End With
Set IE = Nothing
Set HTML_Body = Nothing

UserForm1.TextBox5 = Format(Now, "hh:nn:ss")
If UserForm1.TextBox1 > say1 Then
UserForm1.Label5.BackColor = &HFF&
ElseIf UserForm1.TextBox1 < say1 Then
UserForm1.Label5.BackColor = &HFF00&
ElseIf UserForm1.TextBox1 = say1 Then
UserForm1.Label5.BackColor = &HFFFF&
End If
If UserForm1.TextBox2 > say2 Then
UserForm1.Label6.BackColor = &HFF&
ElseIf UserForm1.TextBox2 < say2 Then
UserForm1.Label6.BackColor = &HFF00&
ElseIf UserForm1.TextBox2 = say2 Then
UserForm1.Label6.BackColor = &HFFFF&
End If
If UserForm1.TextBox3 > say3 Then
UserForm1.Label7.BackColor = &HFF&
ElseIf UserForm1.TextBox3 < say3 Then
UserForm1.Label7.BackColor = &HFF00&
ElseIf UserForm1.TextBox3 = say3 Then
UserForm1.Label7.BackColor = &HFFFF&
End If
If UserForm1.TextBox4 > say4 Then
UserForm1.Label8.BackColor = &HFF&
ElseIf UserForm1.TextBox4 < say4 Then
UserForm1.Label8.BackColor = &HFF00&
ElseIf UserForm1.TextBox4 = say4 Then
UserForm1.Label8.BackColor = &HFFFF&
End If
Application.ScreenUpdating = True
Application.StatusBar = False
UserForm1.Label9 = sayac & " kere güncellendi"
 
Application.OnTime Now + TimeValue("00:00:05"), "Auto_Open"
    
End Sub

 

[halit3]

Bu dosya da farklı uygulama

 

[bahaer]

merhaba halit3,
açmış olduğum konuma cevap alamadığım için problemimi burada dile getirdiğim için kusura bakmayın.
aşağıdaki kod ile ilgili linkteki verileri çekebiliyorum ancak 160 sayfa varken sadece ilk sayfadaki verileri alabiliyorum.
160 sayfanın tamamını çekebilmem için desteğinizi rica ediyorum.

Sub ExcelceVeriAl()
konum = ActiveSheet.Range("A65536").End(3).Row + 2
    With ActiveSheet.QueryTables.Add(Connection:= _
        "URL;http://122.11.222.33/osem/list.asp", Destination:=Range("A" & konum))
        .Name = "index"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertEntireRows
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 60
        .WebSelectionType = xlSpecifiedTables
        .WebFormatting = xlWebFormattingNone
        .WebTables = "3"
        .WebPreFormattedTextToColumns = True
        .WebConsecutiveDelimitersAsOne = True
        .WebSingleBlockTextImport = False
        .WebDisableDateRecognition = False
        .WebDisableRedirections = False
        .Refresh BackgroundQuery:=False
    End With
    Application.OnTime Now + TimeValue("01:00:00"), "ExcelceVeriAl"
End Sub

 

[arslanbey]

Merhaba Halit bey sizin eklediğiniz örnekte makroyu durdur butona bastığımız halde hala makro çalışıyor güncelleme yapıyor.

 

[halit3]

Merhaba Halit bey sizin eklediğiniz örnekte makroyu durdur butona bastığımız halde hala makro çalışıyor güncelleme yapıyor.

24 nolu mesajdaki dosyayı denedim durdur düğmesine basınca duruyor.