Makro timevalue otomatik durması

[sebastianmbl]

Arkadaşlar merhaba,

Aşağıda ki makroda her 10 saniyede bir satır silme işlemi otomatik yapıyor,

Benim sorum; Bu makroya nasıl bir ekleme yapmalıyız ki;

1. Mesela 40 kere makro çalıştıktan sonra otomatik olarak kendini durdursun

2. veya belli bir süre tanımlansın ve o süre sonunda otomatik dursun

Hangisi mümkün ise yardımcı olabilir misiniz?

Sub XY()
dTime = Now + TimeValue("00:00:10")
Application.OnTime dTime, "XY"
For Each alan In Workbooks("A.xlsm").Worksheets
alan.Rows("1:10").Delete Shift:=xlUp
Next
End Sub

Teşekkürler

 

[halit3]

Kod:

Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
Dim NextTick As Date
Dim kontrol, sayac

Sub calistir()
kontrol = True
makro
zaman = ("00:00:10") 'CDate(Cells(1, "m").Value)
NextTick = CDate(Format(Now, "hh:mm:ss")) + TimeValue(zaman)
Application.OnTime NextTick, "calistir", schedule:=True
sayac = sayac + 1
'kırk kere çalışcak sonra duracaktır
If sayac = 40 Then Durdur
End Sub

Sub Durdur()

If kontrol = True Then
Application.OnTime earliesttime:=NextTick, procedure:="calistir", schedule:=False
End If
kontrol = False
sayac = 0
End Sub

Sub makro()
For Each alan In Workbooks("A.xlsm").Worksheets
alan.Rows("1:10").Delete Shift:=xlUp
Next

End Sub

 

[sebastianmbl]

Halit Bey,

Teşekkürler fakat ben toparlayamadım, çok karışık nasıl bir düzenleme gerekir,

Kısaca 40 kere çalıştıktan sonra dursun nasıl düzenliyebilirim

Teşekkürler

 

[halit3]

Halit Bey,

Teşekkürler fakat ben toparlayamadım, çok karışık nasıl bir düzenleme gerekir,

Kısaca 40 kere çalıştıktan sonra dursun nasıl düzenliyebilirim

Teşekkürler

Kendi kodunuzu silin aşağıdaki kodları bir modülün içine kopyalayın ve sayfada komut düğmesine (calıstır) atayın durdurmak içinde (Durdur) makrosunu atayın kırmızı renkli bölüm 40 kereden sonra duracaktır.


kod:

Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
Dim NextTick As Date
Dim kontrol, sayac

Sub calistir()
kontrol = True

For Each alan In Workbooks("A.xlsm").Worksheets
alan.Rows("1:10").Delete Shift:=xlUp
Next

zaman = ("00:00:10") 'CDate(Cells(1, "m").Value)
NextTick = CDate(Format(Now, "hh:mm:ss")) + TimeValue(zaman)
Application.OnTime NextTick, "calistir", schedule:=True

sayac = sayac + 1
'kırk kere çalışcak sonra duracaktır
If sayac = [COLOR="Red"]40[/COLOR] Then Durdur
End Sub

Sub Durdur()

If kontrol = True Then
Application.OnTime earliesttime:=NextTick, procedure:="calistir", schedule:=False
End If
kontrol = False
sayac = 0
End Sub

 

[halit3]

İşlemleri Bu videodaki gibi yapınız.

görsel video

 

[sebastianmbl]

Çok teşekkür ederim kesinlikle mükemmel çalışıyor.