saat başı kod çalıştırma yardım edermisiniz ?

[profhanddrop]

Arkadaşlar bu macroyu ben excel i actıgımda otomatik açılıyor ve saymaya başlıyor bazı verileri checklist olarak kaydediyor anladığınız gbi fakat kaydetme zamanı kitaba zaman kaybettiriyor. benım istedigim bunun pc nin Xp in gerçek saatini görmesi nasıl olur yardımcı olabilirmisiniz

Sub Auto_Open()
   Application.OnTime Now + TimeValue("01:00:00"), "Başla"
End Sub

Sub Başla()
  Dim Satır1 As Integer, Satır2 As Integer
    Satır1 = Sheets("KURUTUCU").Range("C65536").End(3).Row + 1
    Satır2 = Sheets("REFINER").Range("B65536").End(3).Row + 1
    Satır3 = Sheets("DIGER").Range("A65536").End(3).Row + 1
    Satır4 = Sheets("URETIM").Range("A65536").End(3).Row + 1
    Sheets("KURUTUCU").Range("C7:W7").Copy
    Sheets("KURUTUCU").Range("C" & Satır1, "W" & Satır1).PasteSpecial (xlPasteValues)
    Sheets("REFINER").Range("B7:X7").Copy
    Sheets("REFINER").Range("B" & Satır2, "X" & Satır2).PasteSpecial (xlPasteValues)
    Sheets("DIGER").Range("A6:AD6").Copy
    Sheets("DIGER").Range("A" & Satır3, "AD" & Satır3).PasteSpecial (xlPasteValues)
    Sheets("URETIM").Range("A14:T14").Copy
    Sheets("URETIM").Range("A" & Satır4, "T" & Satır4).PasteSpecial (xlPasteValues)
    Application.CutCopyMode = False
        '/_
    Dismi = ActiveWorkbook.Name
    ActiveWorkbook.SaveCopyAs "E:\checklist\ " & Dismi
    ActiveWorkbook.Save
    Range("m14").Select
  Say
End Sub
Sub Say()
   Application.OnTime Now + TimeValue("00:59:42"), "devam"
End Sub
Sub devam()
  Dim Satır1 As Integer, Satır2 As Integer
    Satır1 = Sheets("KURUTUCU").Range("C65536").End(3).Row + 1
    Satır2 = Sheets("REFINER").Range("B65536").End(3).Row + 1
    Satır3 = Sheets("DIGER").Range("A65536").End(3).Row + 1
    Satır4 = Sheets("URETIM").Range("A65536").End(3).Row + 1
    Sheets("KURUTUCU").Range("C7:W7").Copy
    Sheets("KURUTUCU").Range("C" & Satır1, "W" & Satır1).PasteSpecial (xlPasteValues)
    Sheets("REFINER").Range("B7:X7").Copy
    Sheets("REFINER").Range("B" & Satır2, "X" & Satır2).PasteSpecial (xlPasteValues)
    Sheets("DIGER").Range("A6:AD6").Copy
    Sheets("DIGER").Range("A" & Satır3, "AD" & Satır3).PasteSpecial (xlPasteValues)
    Sheets("URETIM").Range("A14:T14").Copy
    Sheets("URETIM").Range("A" & Satır4, "T" & Satır4).PasteSpecial (xlPasteValues)
    Application.CutCopyMode = False
        '/_
    Dismi = ActiveWorkbook.Name
    Range("m14").Select
  Auto_Open
End Sub

 

[profhanddrop]

Sub devam() macrosunuda o zaman aralığını 15 sn kazansın diye yaptım fakat pc nin hızına göre buda değiştiği için yine 1 sn zaman kaybediyor ve sonra dakika değişiyor mümkünse yardımcı olun... mumkun değilse lütfen söylermisiniz

 

[Korhan Ayhan]

Merhaba,

Aşağıdaki şekilde denermisiniz.

Sub Auto_Open()
    DoEvents
    Başla
End Sub
 
Sub Başla()
    Dim Saat As String
    
    DoEvents
        Saat = Format(Time, "hh:mm")
        If Right(Saat, 2) = "00" Then
            Satır1 = Sheets("KURUTUCU").Range("C65536").End(3).Row + 1
            Satır2 = Sheets("REFINER").Range("B65536").End(3).Row + 1
            Satır3 = Sheets("DIGER").Range("A65536").End(3).Row + 1
            Satır4 = Sheets("URETIM").Range("A65536").End(3).Row + 1
            
            Sheets("KURUTUCU").Range("C7:W7").Copy
            Sheets("KURUTUCU").Range("C" & Satır1, "W" & Satır1).PasteSpecial (xlPasteValues)
            Sheets("REFINER").Range("B7:X7").Copy
            Sheets("REFINER").Range("B" & Satır2, "X" & Satır2).PasteSpecial (xlPasteValues)
            Sheets("DIGER").Range("A6:AD6").Copy
            Sheets("DIGER").Range("A" & Satır3, "AD" & Satır3).PasteSpecial (xlPasteValues)
            Sheets("URETIM").Range("A14:T14").Copy
            Sheets("URETIM").Range("A" & Satır4, "T" & Satır4).PasteSpecial (xlPasteValues)
            Application.CutCopyMode = False
            
            Dismi = ActiveWorkbook.Name
            ActiveWorkbook.SaveCopyAs "E:\checklist\ " & Dismi
            ActiveWorkbook.Save
            Range("m14").Select
        End If
    Application.OnTime Now + TimeValue("00:00:01"), "Auto_Open"
End Sub