belirli aralıklarla otomatik çalışan makro

[GursoyC]

Merhabalar,
forumda aradım, zaman ayarlı makro için üstadların örnekleri var.
Ancak makromuzun belirleyeceğimiz aralıklarla (örneğin 20 saniyede bir) çalışmasını sağlayacak bir koda yönelik bir örnek yok.
Böyle bir kod mevcut mudur acaba?

Bir düğmeye atadığım aşağıdaki gibi bir kodum var.
Bunun 20 saniyede bir otomatik çalışmasını istiyorum ama mümkün müdür?
Teşekkürler.


Sub YuvarlatılmışDikdörtgen3_Tıkla()
Dim conn As Object, rs As Object
Set conn = CreateObject("Adodb.connection")
Set rs = CreateObject("Adodb.recordset")
Sheet17.ComboBox31.ListFillRange = ""
'Range("A:A").ClearContents
conn.Open "provider=microsoft.ace.oledb.12.0;data source=" & ThisWorkbook.Path & _
"\müşteri_kayıtları_V1.2.xlsm;extended properties=""excel 12.0;hdr=no"""
rs.Open "select * from[müşteri_listesi$j2:j20000];", conn, 1, 1
If rs.RecordCount > 0 Then
Sheet17.ComboBox31.Column = rs.getrows
Sheet17.ComboBox31.ListIndex = 0
End If
rs.Close: conn.Close
Set rs = Nothing: Set conn = Nothing
MsgBox "Veriler Güncellendi!" & vbLf & "İşleminize Devam edebilirsiniz"
End Sub

 

[yanginci34]

Merhaba; aşağıdaki kodu da ekleyin ve kendi kodunuza da End Sub tan evvel Call auto_open yazıp denermisiniz

Sub auto_open()
Application.OnTime Now + TimeValue("00:00:20"), "YuvarlatılmışDikdörtgen3_Tıkla"
End Sub

 

[GursoyC]

Çok teşekkür ederim, gayet güzel çalışıyor.

 

[yanginci34]

Rica ederim kolay gelsin.

 

[xadm103]

Aşağıdaki makroyu her 10 saniyede bir otomatik çalışsın istiyorum. Bunu nasıl yapabilirim? Teşekkürler









Sub test()
Dim myData As Object, retVal As Object, statistics As Object
Dim url$, response$, i&, arr()
With CreateObject("MSXML2.XMLHTTP")
url = "https://api.binance.com/api/v3/ticker/24hr"
.Open "GET", url, False
.send
response = .responseText
.abort
End With
With CreateObject("MSScriptControl.ScriptControl")
.Language = "JScript"
Set retVal = .Eval("(" & response & ")")
End With
With Sheets("Sayfa1")
.Range("A1:c" & Rows.Count) = ""
arr = Array("symbol", "bidPrice", "askPrice")
.Range("A1:C1") = arr
.Range("A1:C1").Font.Bold = True
.Range("A1:C1").Font.Color = vbRed
i = 2
For Each myData In retVal
For ii = 1 To 3
.Cells(i, ii) = VBA.CallByName(myData, arr(ii - 1), VbGet)
Next ii
i = i + 1
Next
.Columns.AutoFit
End With
Set retVal = Nothing

End Sub