Farklı kaydet ile kaydedilen dosyada makrolar çalışmıyor

[mozakay]

Arkadaşlar aşağıdaki kod ile tarih bazlı arşivleme yapılıyor.
ancak 4,5 MB boyutundaki dosya arşivlendiğinde 41 bayt olarak arşivleniyor ve makrolar çalışmıyor. sanırım farklı kaydederken makro içerebilen çalışma kitabı şeklinde kaydetmiyor. bunu nasıl düzeltebiliriz. yardımcı olabilecek bir arkadaş var mıdır?

Sub FARLIKAYDET()



ThisWorkbook.Save
Application.ScreenUpdating = False
Application.DisplayAlerts = False
 
 a = MsgBox("RAPOR KAYDEDİLENLER KLASÖRÜNE KAYIT EDİLECEKTİR. DEVAM ETMEK İSTİYOR MUSUNUZ?", vbOKCancel)
If a = vbCancel Then Exit Sub

On Error GoTo 10
 
 
 
 Set Dosya = CreateObject("Scripting.FileSystemObject")
   yol = "D:\GÖNDERİLEN RAPORLAR"
yılyol = "D:\GÖNDERİLEN RAPORLAR\" & Year(Range("O1"))
 ayyol = "D:\GÖNDERİLEN RAPORLAR\" & Year(Range("O1")) & "\" & MonthName(Month(Range("O1")))
 If Not Dosya.FolderExists(yol) Then
        Dosya.CreateFolder (yol)
    End If
 If Not Dosya.FolderExists(yılyol) Then
        Dosya.CreateFolder (yılyol)
    End If
 If Not Dosya.FolderExists(ayyol) Then
        Dosya.CreateFolder (ayyol)
    End If
  gelen = ayyol & "\" & Range("O1") & ".xls"
    If Not Dosya.FileExists(gelen) Then
 Sheets("KAYIT").Copy
 ActiveWorkbook.SaveAs gelen
 ActiveWorkbook.Close
    Else
     Response = MsgBox("Bu dosya var üstüne yazılmasını istiyorsanız 'Evet'e tıklayın", vbYesNo)
     If Response = vbYes Then
    Sheets("KAYIT").Copy
 ActiveWorkbook.SaveAs gelen
 ActiveWorkbook.Close
     End If
   End If
   Application.DisplayAlerts = True
   Application.ScreenUpdating = True
MsgBox "İşlem bitti"

10

End Sub

 

[PLİNT]

Merhaba

Aşağıdaki kodlar dosyanızı kopyalayıp kodlarınızdaki gibi kaydedecektir.
Aynı şekilde devam etmek isterseniz menü "Seçenekler" sekmesinde kaydetme seçenekleri bulunuyor buradan "makro içerebilen" i veya "2003-2007 çalışma kitabı" işaretlersiniz

 Sub FARLIKAYDET()
ThisWorkbook.Save
Application.ScreenUpdating = False
Application.DisplayAlerts = False
 
 a = MsgBox("RAPOR KAYDEDİLENLER KLASÖRÜNE KAYIT EDİLECEKTİR. DEVAM ETMEK İSTİYOR MUSUNUZ?", vbOKCancel)
If a = vbCancel Then Exit Sub
On Error GoTo 10
 Set Dosya = CreateObject("Scripting.FileSystemObject")
   yol = "D:\GÖNDERİLEN RAPORLAR"
yılyol = "D:\GÖNDERİLEN RAPORLAR\" & Year(Range("O1"))
 ayyol = "D:\GÖNDERİLEN RAPORLAR\" & Year(Range("O1")) & "\" & MonthName(Month(Range("O1")))
 If Not Dosya.FolderExists(yol) Then
        Dosya.CreateFolder (yol)
    End If
 If Not Dosya.FolderExists(yılyol) Then
        Dosya.CreateFolder (yılyol)
    End If
 If Not Dosya.FolderExists(ayyol) Then
        Dosya.CreateFolder (ayyol)
    End If
  gelen = ayyol & "\" & Range("O1") & [COLOR="Red"]".xlsm"[/COLOR]
    If Not Dosya.FileExists(gelen) Then
 ActiveWorkbook.[COLOR="Red"]SaveCopyAs[/COLOR] gelen
    Else
     Response = MsgBox("Bu dosya var üstüne yazılmasını istiyorsanız 'Evet'e tıklayın", vbYesNo)
     If Response = vbYes Then
 ActiveWorkbook.[COLOR="Red"]SaveCopy[/COLOR]As gelen
     End If
   End If
   Application.DisplayAlerts = True
   Application.ScreenUpdating = True
MsgBox "İşlem bitti"

10
End Sub

 

[mozakay]

Teşekkürler sayın Plint.
Sorun çözüldü.
Active çalışma kitabının kapanması lazım. Çünkü SaveAs dan sonra yeni dosya ismi alıyor.
Kapanan dosyanın tekrar açılma imkanı var mı?
Dosya kapandığında makro çalışmasını durdurduğu için bu pek mümkün görünmüyor gibi.

 

[PLİNT]

Teşekkürler sayın Plint.
Sorun çözüldü.
Active çalışma kitabının kapanması lazım. Çünkü SaveAs dan sonra yeni dosya ismi alıyor.
Kapanan dosyanın tekrar açılma imkanı var mı?
Dosya kapandığında makro çalışmasını durdurduğu için bu pek mümkün görünmüyor gibi.

Yukarıdaki değişen kodları denermisiniz?
Çalıştığınız dosyayı; kopyalayıp "O1" deki tarih adıyla "xlsm" olarak kaydedecektir.
Çalıştığınız dosyada kapanmamış olacaktır.

 

[mozakay]

Çok teşekkürler sayın Plint

İşte bu harika oldu.
Sağlıcakla kalın.