Makroda düzeltme

[zırzır]

Arkadaşlar,Excel sayfasından Makro ile mesai bitiminde "D:\" sürücücüne "Günlük Kayıtlar" ismi ile bir dosya açıp oraya o günkü tarih ile kopya yolluyorum,eğer hata ile mesai bitmeden bir
kopyalama yapılmışsa sistem bunu algılayıp kopyalama yapmayacak ve "Bu günkü tarihli bir
kopya vardır" diye uyarı verecek.Makro aşağıdadır,gerekli değişikliği yapabilirsek çok iyi
olacak sevgiler.

 

[zırzır]

Sevgili arkadaşlar,düşüncelerini paylaşacak kimse yokmu?

 

[xxcell]

Yordamınız başına aşağıdaki kodu ilave ediniz.

If not Dir("D:\Günlük Kayıtlar\"& Format(Now, "dd.mm.yyyy") & ".xls") = Empty Then
msgbox "Bu günkü tarihli bir kopya vardır"
exit sub
endif

 

[zırzır]

Sayın xxcell verdiğiniz kodu ekledim ama çalıştıramadım siz bir denermisiniz.

 

[leumruk]

Sayın xxcell verdiğiniz kodu ekledim ama çalıştıramadım siz bir denermisiniz.

Hata veren satırın üstüne

On Error Resume Next

yazdım düzeldi.
Ama, sonrasında yapılan işlemlerden birini atlıyor mu bilemiyorum? Kendi dosyanızı daha iyi bilirsiniz, eğer bir aksama varsa bildirin, yeniden bakalım.

 

[leumruk]

Sub GünlükAktar()
    Application.ScreenUpdating = False
    Set WB = ActiveWorkbook
    MyFolder = "D:\Günlük Kayıtları"
    MyFile = "" & Format(Now, "dd.mm.yyyy") & ".xls"
    Set FSO = CreateObject("Scripting.FileSystemObject")
    If Not FSO.FolderExists(MyFolder) Then
        FSO.CreateFolder (MyFolder)
    End If
    Sheets(Array("154", "380")).Copy
    With Sheets("154")
        .Range("au2:ec37") = Empty
        .Range("b39:af52") = Empty
        .Cells.ColumnWidth = 3.29
        .Cells.RowHeight = 12.75
    End With
    With Sheets("380")
        .Range("b36:ak78") = Empty
        .Range("at7:ez42") = Empty
        .Cells.ColumnWidth = 3.85
        .Cells.RowHeight = 12.75
    End With
    
    [COLOR="red"]On Error Resume Next[/COLOR]
    
    Set YWB = ActiveWorkbook
    YWB.SaveAs Filename:=MyFolder & "\" & MyFile
    YWB.Close [COLOR="Red"]False[/COLOR]
    WB.Activate
    Set WB = Nothing
    Set YWB = Nothing
    Set FSO = Nothing
    Application.ScreenUpdating = True
End Sub

Kırmızı kısımlar yeni eklediğim bölümler. Birincisi hata olsada işlemin devam etmesini sağlıyor. İkincisi(False) Geçici excel dosyası kapanırken, "Kaydetmek istiyor musunuz?" sorgu ekranının çıkmasını engelliyor.
Dosyayı kontrol ettim. İşlemleri sıarasına göre gerçekleştiriyor. İlk çalıştırmada D:'de klasörü oluşturuyor ve günün tarihine göre kayıt yapıyor. İkinci denemede, aynı dosyayı kaydetip, etmeme seçeneğini size bırakıyor.

 

[uzmanamele]

merhaba
ben bu konuyu bilmiyorum, bilen arkadaşların yardımcı olacağını temenni ederim!!!

syn zırzır, beklediğiniz cevap bu değil sanıyorum ama elimden gelen bu.
bu cevap sizce yeterli mi!?

 

[zırzır]

Sayın leumruk,teşekkür ederim,daha önce "workbook sınıfının SaveAs yöntemi başarısız" diye
bir uyarı çıkıyordu,yaptığınız değişiklikten sonra düzeldi artık çıkmıyor,ilgine teşekkür ederim.
Sayın uzmanamele hassasiyetinizden dolayı sizede müteşekkirim.