Web'den Döviz Bilgilerini Alma Otomatik

arslanbey · 3 Nisan 2012

Webden döviz bilgilerini UserFrom'daki textbox alıyorum fakat yapmak istediğim her 15 dakikada otomatik kendisi güncelleyecek.UserFrom birde label eklenip eğerki döviz bilgilerinde düşme olursa label kırmızı renk olacak,yükselme olursa label yeşil renk olacak,Sabit kalırsa label sarı renk olacak bunu yapmak mümkünmüdür.

arslanbey · 3 Nisan 2012

Yardım edecek kimse yokmu.?

arslanbey · 4 Nisan 2012

Olmayacak birşey içinmi yardım istedim yoksa.

halit3 · 4 Nisan 2012

arslanbey' Alıntı:
Olmayacak birşey içinmi yardım istedim yoksa.

Kod beş saniye için ayarlandı siz zamanı kendinize göre ayarlayın

Userformun içinde kod olmayacak

ThisWorkbook kodu

Kod:

Private Sub Workbook_Open()
UserForm1.Show 0
End Sub

modül kodu

Kod:

Dim sayac
Sub Auto_Open()
   Application.OnTime Now + TimeValue("00:00:05"), "devamet"
   '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
 
   Set S2 = Sheets("KURLAR")
    TARİH = Date
 
    S2.Cells.Delete
    Application.StatusBar = "Kur bilgileri alınıyor. Lütfen bekleyiniz..."
    S2.Select
 
    With Application
        .DecimalSeparator = "."
        .ThousandsSeparator = ","
        .UseSystemSeparators = False
    End With
 
 
 
    With ActiveSheet.QueryTables.Add(Connection:="URL;http://www.tcmb.gov.tr/yeni/tablolar.php", Destination:=S2.[A1])
        .Name = "KURLAR"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .WebSelectionType = xlSpecifiedTables
        .WebFormatting = xlWebFormattingNone
        .WebTables = "4"
        .WebPreFormattedTextToColumns = True
        .WebConsecutiveDelimitersAsOne = True
        .WebSingleBlockTextImport = False
        .WebDisableDateRecognition = False
        .WebDisableRedirections = False
        .Refresh BackgroundQuery:=False
    End With
    With Application
        .UseSystemSeparators = True
    End With
 
    S2.[B:C].NumberFormat = "#,##0.0000"
    S2.[A6] = Date
    S2.[A7].NumberFormat = "m/d/yyyy"
 
 
    Set S2 = Nothing
    Application.ScreenUpdating = True
    Application.StatusBar = False
    'MsgBox Format(TARİH, "dd.mm.yyyy") & "   tarihli T.C.M.B. kur bilgileri başarıyla alınmıştır.", vbInformation, "Dikkat !"
 
Sheets("KURLAR").Cells(1, 4).Value = sayac & " kere güncellendi"
UserForm1.TextBox1 = Sheets("KURLAR").Cells(3, "b").Value
UserForm1.TextBox2 = Sheets("KURLAR").Cells(3, "c").Value
UserForm1.TextBox3 = Sheets("KURLAR").Cells(4, "b").Value
UserForm1.TextBox4 = Sheets("KURLAR").Cells(4, "c").Value
[COLOR=red]UserForm1.TextBox5 = Format(Now, "hh:nn:ss")[/COLOR]
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
 
 
    Set S2 = Nothing
     Application.OnTime Now + TimeValue("00:00:05"), "Auto_Open"
 
End Sub

arslanbey · 4 Nisan 2012

Hocam teşekkür ederim ilginizden dolayı fakat textbox düşme veya yükselme veya sabit olursa labellerde renk değişimi olacakmı.Birde güncellediği saati yazdıra bilirmiyiz textbox günceleme yaptıkça saat değişimi yaptırabilirmiyiz.

halit3 · 4 Nisan 2012

arslanbey' Alıntı:
Hocam teşekkür ederim ilginizden dolayı fakat textbox düşme veya yükselme veya sabit olursa labellerde renk değişimi olacakmı.Birde güncellediği saati yazdıra bilirmiyiz textbox günceleme yaptıkça saat değişimi yaptırabilirmiyiz.

Kod:

UserForm1.TextBox5 = Sheets("KURLAR").Cells(6, "a").Value

kodun yukarıdaki bölümünü aşağıdakiyle değiştirin

Kod:

UserForm1.TextBox5 = Format(Now, "hh:nn:ss")

arslanbey · 4 Nisan 2012

Hocam teşekkür ederim ilginizden dolayı fakat textboxlarda düşme veya yükselme veya sabit olursa labellerde renk değişimi olacakmı.Yani döviz kurunda düşme olduğunda label kırmızı renge dönüşmesi yükselme olursa label yeşil renge dönüşmesi sabet kaldığındada label sarı renklere dönecekmi hocam.

halit3 · 4 Nisan 2012

arslanbey' Alıntı:
Hocam teşekkür ederim ilginizden dolayı fakat textboxlarda düşme veya yükselme veya sabit olursa labellerde renk değişimi olacakmı.Yani döviz kurunda düşme olduğunda label kırmızı renge dönüşmesi yükselme olursa label yeşil renge dönüşmesi sabet kaldığındada label sarı renklere dönecekmi hocam.

İki mesajdada aynı soruyu soruyorsunuz size gönderdiğim 4 nolu mesajdaki dosyayı açıp baktınızmı hiç, dört nolu mesajdaki dosya her beş saniyede yenileniyor bir dakikanızı ayır ve gözlemleyin.

arslanbey · 4 Nisan 2012

Tamam hocam çok teşekkür ederim Allah razı olsun hocam.

arslanbey · 6 Nisan 2012

İnternet olmadığı zaman hata veriyor hata vermemesi için ne yapabiliriz.

halit3 · 6 Nisan 2012

arslanbey' Alıntı:
İnternet olmadığı zaman hata veriyor hata vermemesi için ne yapabiliriz.

Sub Aut

pen()

yukarıdaki bölümden sonra aşağıdakini koy

Kod:

On Error Resume Next

arslanbey · 6 Nisan 2012

Hocam dediğiniz gibi yaptım yine aynı hatayı veriyor.Hata veripde kod sarı olan kod bu '

.Refresh BackgroundQuery:=False

Peki hocam internet bağlantınız yok diye mesaj verdirebilirmiyiz.

halit3 · 7 Nisan 2012

arslanbey' Alıntı:
Hocam dediğiniz gibi yaptım yine aynı hatayı veriyor.Hata veripde kod sarı olan kod bu 'Peki hocam internet bağlantınız yok diye mesaj verdirebilirmiyiz.

kod

Kod:

Private Declare Function InternetCheckConnection Lib "wininet.dll" Alias "InternetCheckConnectionA" (ByVal lpszUrl As String, ByVal dwFlags As Long, ByVal dwReserved As Long) As Long
Dim sayac
Sub Auto_Open()
If (InternetCheckConnection("[URL]http://www.tcmb.gov.tr/yeni/kurlar/kurlar_tr.php/[/URL]", &H1, 0&) = 0) Then
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
  
   Set S2 = Sheets("KURLAR")
    TARİH = Date
    
    S2.Cells.Delete
    Application.StatusBar = "Kur bilgileri alınıyor. Lütfen bekleyiniz..."
    S2.Select
    
    With Application
        .DecimalSeparator = "."
        .ThousandsSeparator = ","
        .UseSystemSeparators = False
    End With
    
    
    
    With ActiveSheet.QueryTables.Add(Connection:="URL;http://www.tcmb.gov.tr/yeni/tablolar.php", Destination:=S2.[A1])
        .Name = "KURLAR"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .WebSelectionType = xlSpecifiedTables
        .WebFormatting = xlWebFormattingNone
        .WebTables = "4"
        .WebPreFormattedTextToColumns = True
        .WebConsecutiveDelimitersAsOne = True
        .WebSingleBlockTextImport = False
        .WebDisableDateRecognition = False
        .WebDisableRedirections = False
        .Refresh BackgroundQuery:=False
    End With
    With Application
        .UseSystemSeparators = True
    End With
    
    S2.[B:C].NumberFormat = "#,##0.0000"
    S2.[A6] = Date
    S2.[A7].NumberFormat = "m/d/yyyy"
    
    
    Set S2 = Nothing
    Application.ScreenUpdating = True
    Application.StatusBar = False
    'MsgBox Format(TARİH, "dd.mm.yyyy") & "   tarihli T.C.M.B. kur bilgileri başarıyla alınmıştır.", vbInformation, "Dikkat !"
   
Sheets("KURLAR").Cells(1, 4).Value = sayac & " kere güncellendi"
UserForm1.TextBox1 = Sheets("KURLAR").Cells(3, "b").Value
UserForm1.TextBox2 = Sheets("KURLAR").Cells(3, "c").Value
UserForm1.TextBox3 = Sheets("KURLAR").Cells(4, "b").Value
UserForm1.TextBox4 = Sheets("KURLAR").Cells(4, "c").Value
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
 
 
    Set S2 = Nothing
     Application.OnTime Now + TimeValue("00:00:05"), "Auto_Open"
    
End Sub

arslanbey · 7 Nisan 2012

Teşekkürler hocam bu sefer oldu.

arslanbey · 6 Ağustos 2012

Halit hocam bu labellerdeki renkleri nasıl değiştirebiliriz.

arslanbey · 13 Ağustos 2012

Sn;Halit hocam son yazdığım mesaj ile fikrinizi alabilirmiyim.

halit3 · 13 Ağustos 2012

arslanbey' Alıntı:
Sn;Halit hocam son yazdığım mesaj ile fikrinizi alabilirmiyim.

Sorunuzu anlıyamadığım için cevap vermekten kaçınıyorum.

Kodlardaki label nesnelerine ait renklendirme örnek olarak

label6 nesnesi için

UserForm1.Label6.BackColor = &HFF&
veya
UserForm1.Label6.BackColor = 255

label7 nesnesi için

UserForm1.Label7.BackColor = &HFF00&
veya
UserForm1.Label7.BackColor = 65280

label8 nesnesi için

UserForm1.Label8.BackColor = &HFFFF&
veya
UserForm1.Label8.BackColor = 65535

Kodların yukarıdaki bölümlerinde renklendirme olayı yapılmaktadır.

Ergün Güler · 8 Ekim 2012

Halit Hocam,
çözümlerinizi inceledim. Çok teşekkür ederim.
aşağıdaki kodlar ile, çözümünü yaptığınız dosyaya uygulayıp kaç tane querytable var öğremek istediğimizde 100'lerce tablonun oluştuğunu görüyoruz. bunun sebebi nedir? neden aynı tablo üzerine güncelleme yapılmıyor?

Kod:

Sub tablolar()
Dim s1 As Worksheet

Set s1 = Worksheets("KURLAR")
For i = 1 To s1.QueryTables.Count
deg = deg & vbLf & s1.QueryTables(i).Name
Next

MsgBox deg & "-" & s1.QueryTables.Count
End Sub

Korhan Ayhan · 8 Ekim 2012

Merhaba,

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

Kod:

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.

halit3 · 8 Ekim 2012

Ergün Güler' Alıntı:
Halit Hocam,
çözümlerinizi inceledim. Çok teşekkür ederim.
aşağıdaki kodlar ile, çözümünü yaptığınız dosyaya uygulayıp kaç tane querytable var öğremek istediğimizde 100'lerce tablonun oluştuğunu görüyoruz. bunun sebebi nedir? neden aynı tablo üzerine güncelleme yapılmıyor?

Kod:

Sub tablolar() Dim s1 As Worksheet Set s1 = Worksheets("KURLAR") For i = 1 To s1.QueryTables.Count deg = deg & vbLf & s1.QueryTables(i).Name Next MsgBox deg & "-" & s1.QueryTables.Count End Sub

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

Kod:

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

bunu ekleyin

Kod:

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

Web'den Döviz Bilgilerini Alma Otomatik

arslanbey

Ekli dosyalar

arslanbey

arslanbey

halit3

Uzman

Ekli dosyalar

arslanbey

halit3

Uzman

arslanbey

halit3

Uzman

arslanbey

arslanbey

halit3

Uzman

arslanbey

halit3

Uzman

arslanbey

arslanbey

arslanbey

halit3

Uzman

Ergün Güler

Korhan Ayhan

Administrator

halit3

Uzman