• DİKKAT

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

Kur alma anındaki saati bütün sütuna yapştırma sorunu

  • Konbuyu başlatan Konbuyu başlatan cems
  • Başlangıç tarihi Başlangıç tarihi
cems

cems

Altın Üye
Katılım
2 Eylül 2005
Mesajlar
2,581
Excel Vers. ve Dili
office 2010 tr 32bit
Ekteki programda , bir bankanın serbest piyasa sayfasından anlık ( sabit zamanlı mesela 3 dakikada 1 ) kur alıp bunları altalta listelettim. Veri TL eki ile geldiğinden bul boşluk yap kodları ile bunu kaldırdım ( aksi durumda grafik hata veriyor )ve çoklu eğri grafiğine taban olarak aldırdım.

Sorun ; her satır eklendiğinde c hücresinin 1ci soluna saat 2ci soluna tarih de alırken son alınan saat bütün saat sütununa kaydediliyor. F8 ile adımlayarak da sebebini bulamadım.

Bütün sütun son alınan saate uyunca da grafik saate göre eğri oluşturamıyor. Ekte bulunan dosyada sebebini ve düzeltilmesi için ne yapılması gerektiği konusunda bilgi almam mümkün mü ?

http://s8.dosya.tc/server4/q1jstn/Kuraloto.rar.html
 
kur al kodunu bununla değiştirip denermisiniz.

Kod: 
Sub kurlarial()

'On Error Resume Next
Set ie = CreateObject("InternetExplorer.Application")
ie.navigate "http://www.qnbfinansbank.enpara.com/doviz-kur-bilgileri/doviz-altin-kurlari.aspx"
Do: DoEvents: Loop Until ie.ReadyState = 4

Son_Dolu_Satir = Sheets("sayfa1").[COLOR="Red"]Cells(Rows.Count, "c")[/COLOR].End(xlUp).Row
Bos_Satir = Son_Dolu_Satir + 1

Sheets("sayfa1").Cells(Bos_Satir, 1) = Format(Now, "dd.mm.yyyy")
Sheets("sayfa1").Cells(Bos_Satir, 2) = Format(Now, "hh:nn")
sut = 2
sat = 0
For i = 1 To 11
sat = sat + 1
If sat = 3 Then
sat = 0
Else
sut = sut + 1

KurAlis = Replace(ie.Document.getElementsByClassName("dlCont")(i).innerText, "TL", "") * 1
[COLOR="Red"]Sheets("sayfa1").Cells(Bos_Satir, sut).NumberFormat = "General"[/COLOR]
Sheets("sayfa1").Cells(Bos_Satir, sut) = KurAlis
End If
Next
Set ie = Nothing

End Sub
 
Sayfa1 deki bu kodları sil

Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)

If Not Intersect(Target, [c1:c136]) Is Nothing Then
Son_Dolu_Satir = Sheets("sayfa1").Range("c136").End(xlUp).Row
Cells(Target.Row, "A") = Format(Now, "dd.mm.yyyy ")
Cells(Target.Row, "B") = Format(Time, "hh:mm")
End If
End Sub
 
Sayfadaki kodları ve moduldeki kodların hepsini silin bu kodu bir modülün içine kopyalayın ve bir komut suğmesi ile çalıştırın. her 10 sn de veriler gelecektir.
kodu durdurmak için durdur makrosunu çalıştırın.

not I1 ve J1 Hücrelerinede çeyrek altın başlıklarını yazın

Kod: 
Dim CD As Date
Sub RunTime()
CD = Now + TimeValue("00:00:10")
Application.OnTime CD, "kurlarial"
'Call Makro
End Sub

Sub Durdur()
'On Error Resume Next
Application.OnTime Earliesttime:=CD, procedure:="kurlarial", schedule:=False
End Sub
Sub kurlarial()

'On Error Resume Next
Set ie = CreateObject("InternetExplorer.Application")
ie.navigate "http://www.qnbfinansbank.enpara.com/doviz-kur-bilgileri/doviz-altin-kurlari.aspx"
Do: DoEvents: Loop Until ie.ReadyState = 4

Son_Dolu_Satir = Sheets("sayfa1").Cells(Rows.Count, "c").End(xlUp).Row
Bos_Satir = Son_Dolu_Satir + 1

Sheets("sayfa1").Cells(Bos_Satir, 1) = Format(Now, "dd.mm.yyyy")
Sheets("sayfa1").Cells(Bos_Satir, 2) = Format(Now, "hh:nn")
sut = 2
sat = 0
For i = 1 To 11
sat = sat + 1
If sat = 3 Then
sat = 0
Else
sut = sut + 1

KurAlis = Replace(ie.Document.getElementsByClassName("dlCont")(i).innerText, "TL", "") * 1
Sheets("sayfa1").Cells(Bos_Satir, sut).NumberFormat = "General"
Sheets("sayfa1").Cells(Bos_Satir, sut) = KurAlis
End If
Next
Set ie = Nothing
son = Sheets("sayfa1").Cells(Rows.Count, "c").End(xlUp).Row
ActiveSheet.ChartObjects("Grafik 1").Activate
ActiveChart.SetSourceData Source:=Range("A1:J" & son)
Range("a1").Select

Call RunTime
End Sub
 
kur al kodunu bununla değiştirip denermisiniz.
Genişletmek için tıkla ...

Sayın Halit3 ;

Kodlar mükemmel şekilde çalıştı , 1 saatlik izlemede saat damgası ile beraber anlık olarak grafiğe de sorunsuz yansıdı.

Hatta excelin kur alırken kasılması da sona ermiş , gayet sağlıklı bir tablo yaratıyor.

Çeyrek kısmını aşırı kasmaya neden oluyor sanısı ile gözardı etmiştim, siz onu da farkedip eklemişsiniz ...

Çok teşekkür ederim , elinize sağlık :)
 
K1 ve L1 hücrelerine EUR/USD ALIŞ EUR/USD SATIŞ başlıklarınıda yaz aşağıdaki kodu çalıştır.

Kod: 
Dim CD As Date
Sub RunTime()
CD = Now + TimeValue("00:00:10")
Application.OnTime CD, "kurlarial"
'Call Makro
End Sub

Sub Durdur()
'On Error Resume Next
Application.OnTime Earliesttime:=CD, procedure:="kurlarial", schedule:=False
End Sub
Sub kurlarial()

'On Error Resume Next

Dim ie As Object

Set ie = CreateObject("InternetExplorer.Application")
ie.Navigate "http://www.qnbfinansbank.enpara.com/doviz-kur-bilgileri/doviz-altin-kurlari.aspx"

ie.Visible = 0


Do Until ie.ReadyState = 4: DoEvents: Loop
Do While ie.Busy: DoEvents: Loop


Son_Dolu_Satir = Sheets("sayfa1").Cells(Rows.Count, "c").End(xlUp).Row
Bos_Satir = Son_Dolu_Satir + 1

Sheets("sayfa1").Cells(Bos_Satir, 1) = Format(Now, "dd.mm.yyyy")
Sheets("sayfa1").Cells(Bos_Satir, 2) = Format(Now, "hh:nn")
sut = 2
sat = 0
For i = 1 To 11
sat = sat + 1
If sat = 3 Then
sat = 0
Else
sut = sut + 1

KurAlis = Replace(ie.document.getElementsByClassName("dlCont")(i).innertext, "TL", "") * 1
Sheets("sayfa1").Cells(Bos_Satir, sut).NumberFormat = "General"
Sheets("sayfa1").Cells(Bos_Satir, sut) = KurAlis
End If
Next


Sheets("sayfa1").Cells(Bos_Satir, 11).NumberFormat = "General"
Sheets("sayfa1").Cells(Bos_Satir, 11) = ie.document.getElementsByClassName("dlContParite")(0).innertext * 1

Sheets("sayfa1").Cells(Bos_Satir, 12).NumberFormat = "General"
Sheets("sayfa1").Cells(Bos_Satir, 12) = ie.document.getElementsByClassName("dlContParite")(1).innertext * 1

ie.Quit
Set ie = Nothing
son = Sheets("sayfa1").Cells(Rows.Count, "c").End(xlUp).Row
ActiveSheet.ChartObjects("Grafik 1").Activate
ActiveChart.SetSourceData Source:=Range("A1:L" & son)
Range("a1").Select

Call RunTime
End Sub
 
bu kod farklı istenen tarihin verisini alıyor.

Kod: 
Sub kurlarial5()

On Error Resume Next

Dim ie As Object

tarih = [COLOR="Red"]"17/04/2017"[/COLOR]

Set ie = CreateObject("InternetExplorer.Application")
ie.Navigate "http://www.qnbfinansbank.enpara.com/doviz-kur-bilgileri/doviz-altin-kurlari.aspx"

ie.Visible = 0

Do: DoEvents: Loop Until ie.ReadyState = 4

ie.document.all("dateText").Focus
ie.document.all("dateText").Value = tarih


Application.Wait (Now + TimeValue("00:00:01"))
Do Until ie.ReadyState = 4: DoEvents: Loop
Do While ie.Busy: DoEvents: Loop
Do Until ie.ReadyState = 4: DoEvents: Loop

ie.document.all("dateText").OnChange

Application.Wait (Now + TimeValue("00:00:01"))
Do Until ie.ReadyState = 4: DoEvents: Loop
Do While ie.Busy: DoEvents: Loop
Do Until ie.ReadyState = 4: DoEvents: Loop

Son_Dolu_Satir = Sheets("sayfa1").Cells(Rows.Count, "c").End(xlUp).Row
Bos_Satir = Son_Dolu_Satir + 1

Sheets("sayfa1").Cells(Bos_Satir, 1) = tarih
Sheets("sayfa1").Cells(Bos_Satir, 2) = Format(Now, "hh:nn")
sut = 2
sat = 0
For i = 1 To 11
sat = sat + 1
If sat = 3 Then
sat = 0
Else
sut = sut + 1

KurAlis = Replace(ie.document.getElementsByClassName("dlCont")(i).innertext, "TL", "") * 1
Sheets("sayfa1").Cells(Bos_Satir, sut).NumberFormat = "General"
Sheets("sayfa1").Cells(Bos_Satir, sut) = KurAlis
End If
Next

Sheets("sayfa1").Cells(Bos_Satir, 11).NumberFormat = "General"
Sheets("sayfa1").Cells(Bos_Satir, 11) = ie.document.getElementsByClassName("dlContParite")(0).innertext * 1

Sheets("sayfa1").Cells(Bos_Satir, 12).NumberFormat = "General"
Sheets("sayfa1").Cells(Bos_Satir, 12) = ie.document.getElementsByClassName("dlContParite")(1).innertext * 1

ie.Quit
Set ie = Nothing

End Sub
 
Her şey iyi derken , son düzeltmenizde

Set ie = CreateObject("InternetExplorer.Application")

Satırında hata verdi. Verdiği hata Automation error .

Bunu aşamayınca kur alamıyor ,saati yazıp kalıyor
Dolayısı ile grafik de karışıyor.

Aşırı sık başvurma nedeni ile bir şekilde gönderen server reddedebilir diye 1 dakikaya çıkardım
ancak error vermeye devam etti
 
İstenen tarihin verisi harika bir fikir , bunu ayrıca deneyeceğim :)

Automation error un sebebini anlamaya çalışıyorum . Sanıyorum sizde sorun gorunmedi bu satırda ... IP bloke mi diye net bağlantısını da yenileyeceğim bakalım ne olacak
 
Son düzenleme:
IP yeniledim automation error devam etti.

Bilgisayarı resetleyince kurlar çalıştı , sanıyorum aşırı sık çağrı hafızada problem yaratıyor ve donmaya doğru götürüyor .

Son kodlarla bu sefer de saat karıştı , şu an excelde bu dosyayı gönderdiğim andan 12 dk ilerde bir saat gösteriyor

Sizi yoruyorum

http://s4.dosya.tc/server4/nq1v9z/Kuraloto_saat_karisti.rar.html
 
6 nolu mesajdaki kodları güncellemiştim onları yeniden deneyiniz.

Kod: 
Sheets("sayfa1").Cells(Bos_Satir, 2) = Format(Now, "hh:[COLOR="Red"]nn[/COLOR]")
saat bölümü burada bilgisayarınızın saati doğru ise o saati buraya aktarıyor.
 
tamam şimdi fark ettim kodun
bu kısmını

Kod: 
Sheets("sayfa1").Cells(Bos_Satir, 2) = Format(Now, "hh:ss")

bununla değiştir.

Kod: 
Sheets("sayfa1").Cells(Bos_Satir, 2) = Format(Now, "hh:[COLOR="Red"]nn[/COLOR]")
 
Sayın Halit3

Dakikadaki düzeltmeden sonra kendi halinde 1 saat kadar bıraktım , hiç sorun çıkarmadı. Bir saatin sonunda yine automation error vererek set ie satırında durdu.

Öyle sanıyorum ki hafıza bitiyor zira şu an foruma yazarken de yazılar gecikmeli olarak klavyeden sayfaya geçiyor.

set ie = nothing var mı diye baktım; var , yine de kendini tüketiyor sanıyorum

Kur alma zamanını 5 dakikaya yukselterek 2 ci bir izleme süreci yapıp sonuca bakacağım, bu arada diğer vermiş olduğunuz tarihe göre kodları denemek icin baska bir excel hazırlayacağım. İş arasında ikisi birden sanırım 2 saati bulur , sonucu buradan tekrar bildireceğim
 
6 nolu mesajdaki kodu güncellemiştim explorer gizli olarak açık kalıyordu şimdi kendisini kapatıyor belki oradan kaynaklanıyor olabilir yada ilgili site belli bir zaman sonra kısıtlama yapıyor olabilir.

veya bu bölümü aktif et

Kod: 
'On Error Resume Next
 
6 Nolu mesajdaki kodları tekrar aldım , 5 dakika zamanlama yaparak açık bıraktım izlemek için .

on error resume next de automation erroru gecememisti ya da gecse de alınan bir şey olmuyordu , sadece saat çıkıp geçiyordu.

Olasılıkla explorer gizli ama açık birikip tıkanmaya sebep oluyordu. 1 saat bunu boyle bırakıp diğer tarihe gore kod ile iş arasında uğraşmaya devam edeceğim ,sonucu yazarım tekrar

edit : Automation error verdi hemen , resume next ile de geçmedi . resetten sonra sanırım baya uzun süre akacak. Galiba sorun biriken explorerlarda ...
 
Sayın Halit3 ;

Sanırım bu gizli biriken ie problemine çözüm bulmak gerekecek , eninde sonunda aynı satırda her şey iyi giderken automation error veriyor. Exceli kapatıp açmak değil , reset sıfırlıyor ve yeniden açıldığında yine rahat başlangıç yapıyor.

Bildiğim kadarı ile Kill ie komutu var da , kodların hangi aşamasında doğru olur , ayrıca doğru düşünce mi emin değilim ...

Öneriniz ne olabilir ?
 
cems' Alıntı:
Sayın Halit3 ;

Sanırım bu gizli biriken ie problemine çözüm bulmak gerekecek , eninde sonunda aynı satırda her şey iyi giderken automation error veriyor. Exceli kapatıp açmak değil , reset sıfırlıyor ve yeniden açıldığında yine rahat başlangıç yapıyor.

Bildiğim kadarı ile Kill ie komutu var da , kodların hangi aşamasında doğru olur , ayrıca doğru düşünce mi emin değilim ...

Öneriniz ne olabilir ?
Genişletmek için tıkla ...

Şimdi bir deneme yapalım bakalım modüldeki bütün kodları silin aşağıdaki kodu bir modüle yapıştırın ve çalıştırın.

bu kod explorer i görün olarak ekranın aşağısına indirerek çalışıyor işi bitince de kapanıyor. birde böyle gözlem yap bakalım ne oluyor.

Kod: 
Private Declare Function InternetCheckConnection Lib "wininet.dll" Alias "InternetCheckConnectionA" (ByVal lpszUrl As String, ByVal dwFlags As Long, ByVal dwReserved As Long) As Long
Private Declare Function apiShowWindow Lib "user32" Alias "ShowWindow" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long

Dim CD As Date
Dim kontrol As Boolean
Sub RunTime()
CD = Now + TimeValue("00:00:10")
Application.OnTime CD, "kurlarial"
'Call Makro
kontrol = True
End Sub

Sub Durdur()
'On Error Resume Next
If kontrol = True Then
Application.OnTime Earliesttime:=CD, procedure:="kurlarial", schedule:=False
kontrol = False
End If
End Sub
Sub kurlarial()

'On Error Resume Next

Dim ie As Object

Set ie = CreateObject("InternetExplorer.Application")
URL = "http://www.qnbfinansbank.enpara.com/doviz-kur-bilgileri/doviz-altin-kurlari.aspx"


If (InternetCheckConnection(URL, &H1, 0&) = 0) Then
MsgBox "Bağlantı Yok"
Durdur
End
Exit Sub
End If


With ie
ie.Visible = 1
ie.Navigate URL

apiShowWindow ie.hwnd, 2

Do Until ie.ReadyState = 4: DoEvents: Loop
Do While ie.Busy: DoEvents: Loop

Son_Dolu_Satir = Sheets("sayfa1").Cells(Rows.Count, "c").End(xlUp).Row
Bos_Satir = Son_Dolu_Satir + 1

Sheets("sayfa1").Cells(Bos_Satir, 1) = Format(Now, "dd.mm.yyyy")
Sheets("sayfa1").Cells(Bos_Satir, 2) = Format(Now, "hh:nn")
sut = 2
sat = 0
For i = 1 To 11
sat = sat + 1
If sat = 3 Then
sat = 0
Else
sut = sut + 1

KurAlis = Replace(ie.document.getElementsByClassName("dlCont")(i).innertext, "TL", "") * 1
Sheets("sayfa1").Cells(Bos_Satir, sut).NumberFormat = "General"
Sheets("sayfa1").Cells(Bos_Satir, sut) = KurAlis
End If
Next

Sheets("sayfa1").Cells(Bos_Satir, 11).NumberFormat = "General"
Sheets("sayfa1").Cells(Bos_Satir, 11) = ie.document.getElementsByClassName("dlContParite")(0).innertext * 1

Sheets("sayfa1").Cells(Bos_Satir, 12).NumberFormat = "General"
Sheets("sayfa1").Cells(Bos_Satir, 12) = ie.document.getElementsByClassName("dlContParite")(1).innertext * 1


ie.Quit: Set ie = Nothing
End With

son = Sheets("sayfa1").Cells(Rows.Count, "c").End(xlUp).Row
ActiveSheet.ChartObjects("Grafik 1").Activate
ActiveChart.SetSourceData Source:=Range("A1:L" & son)
Range("a1").Select

Call RunTime
End Sub
 
Sayın Halit3

Son ve ie açılarak veri alan kodlarda ilk satır için hiç sorun yok , bekleme süresi 5 dk olduğu yani ie nothing kesin olduğu durumda dahi 2ci satırı alırken automation error verdi ve bunu akşama kadar arasıra olan bütün denemelerde yaptı.

Ancak sorun sanırım anlaşıldı gibi ..
Dün akşam ve geceki iki makinada sürdürdüğüm uğraşlarda olan hadise bu error ya da ekranın zombi satırlarla karışması ve anlaşılır olmaktan çıkması oldu. Ancak, ertesi gün dürüm şu şekilde değişti .Ben normal olarak bütün sabahlarda makinenin çöplerini bir yardımcı program ile açılışta boşa ram yemesin diye temizliyorum . Saat 930 sularında bu kodlarla çalışan :

Dim CD As Date
Sub RunTime()
CD = Now + TimeValue("00:01:00")
Application.OnTime CD, "kurlarial"
'Call Makro
End Sub

Sub Durdur()
'On Error Resume Next
Application.OnTime Earliesttime:=CD, procedure:="kurlarial", schedule:=False
End Sub
Sub kurlarial()

On Error Resume Next

Dim ie As Object

Set ie = CreateObject("InternetExplorer.Application")
ie.Navigate "http://www.qnbfinansbank.enpara.com/doviz-kur-bilgileri/doviz-altin-kurlari.aspx"

ie.Visible = 0


Do Until ie.ReadyState = 4: DoEvents: Loop
Do While ie.Busy: DoEvents: Loop


Son_Dolu_Satir = Sheets("sayfa1").Cells(Rows.count, "c").End(xlUp).Row
Bos_Satir = Son_Dolu_Satir + 1

Sheets("sayfa1").Cells(Bos_Satir, 1) = Format(Now, "dd.mm.yyyy")
Sheets("sayfa1").Cells(Bos_Satir, 2) = Format(Now, "hh:nn")
sut = 2
sat = 0
For i = 1 To 11
sat = sat + 1
If sat = 3 Then
sat = 0
Else
sut = sut + 1

KurAlis = Replace(ie.document.getElementsByClassName("dlCont")(i).innertext, "TL", "") * 1
Sheets("sayfa1").Cells(Bos_Satir, sut).NumberFormat = "General"
Sheets("sayfa1").Cells(Bos_Satir, sut) = KurAlis
End If
Next


Sheets("sayfa1").Cells(Bos_Satir, 11).NumberFormat = "General"
Sheets("sayfa1").Cells(Bos_Satir, 11) = ie.document.getElementsByClassName("dlContParite")(0).innertext * 1

Sheets("sayfa1").Cells(Bos_Satir, 12).NumberFormat = "General"
Sheets("sayfa1").Cells(Bos_Satir, 12) = ie.document.getElementsByClassName("dlContParite")(1).innertext * 1

ie.Quit
Set ie = Nothing
'son = Sheets("sayfa1").Cells(Rows.count, "c").End(xlUp).Row
'ActiveSheet.ChartObjects("Grafik 1").Activate
'ActiveChart.SetSourceData Source:=Range("A1:L" & son)
Range("a1").Select
Range("a100").Select
Range("a1").Select
Range("a1").Select
Range("a100").Select
Range("a1").Select
Call RunTime
End Sub
Genişletmek için tıkla ...

programı açık bıraktım , bu arada ie ve belli tarihte kur alan programı da başka makineye attım . Ek olarak grafiği ön sayfadan silip sayfa2 de oluşturdum , zira anladığım kadarı ile yorgun makinaya yük bu şekilde geliyor , üstüne de net kötüleşince error ya da zombiler geliyor. Ayrıca kodların sonuna ekranı sıçratması için iki kere a1 :a100 ekledim , bu sekilde aşagı yukarı yapınca zombiler silindiği ve görüntü düzeldiği icin

Sonuç :
1- Bu şekilde kodlar akşama kadar sorunsuz çalıştı mesele çıkmadı.
2- Grafiği bir kur birimine küçülttüm ve ön sayfaya aldım, altına da alışsatış farkına ek bir grafik daha koydum , bu şekilde de sorunsuz çalıştı.

Teşhis doğru ise ; makine yuklü oldugunda başka program da çalışırsa net de ağırlaşırsa program halatı koparıyor ve automation errore geçip duruyor. Bunu yazıyorum zira programı tesadufen ya da isteyerek indirip kullanacak arkadaşların bu deneyimlere de dikkat edip paniklememesi gerek .

Verdiğiniz yukardaki o ince dokuması ile iyi düşünülerek yazılmış kodlarla yüklü program şu an benim için bugün fevkalade çalıştı . Sanırım ie açıp kapatan programa eğilmeye gerek olmadan bununla yürümeye devam edeceğiz :) Bu aslında daha irice bir programın hareketli parçalarından biriydi, benim için yerine sayenizde oturdu . Son hali şu :

http://s5.dosya.tc/server4/2fo2pm/otomatik_kur_programi_final.rar.html

Ekranın a1:a100 tekrarı ile sıçraması da yaşadığının kanıtı , uzaktan bakmak yetiyor

Keşke buradan size bir Türk kahvesi ikram edebilsem Halit bey , malum hatırı 40 yıl ve sizin hatırınızı 40 yı için kazanmak benim için ayrıcalıklı bir sevinç kaynağı olurdu :) Sizi çok uğraştırdım , bende kul hakkınız varsa helal ederseniz sevinirim .

Elinize sağlık :) Teşekkürlerimle ...

Edit : 23 :00 itibarı ile sıfır sorun sıfır kopma ...
 
Son düzenleme:
Sorun çözülmüş gözüküyor.
Teşekkürler iyi çalışmalar
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst