Dosya yedekleme

ASLAN7410 · 22 Mart 2020

Merhaba, hayırlı günler diliyorum.

Ekte gönderdiğim excel dosyamda dosya yedekleme makrosu mevcut, butona bastığımda dosyanın aynısı masaüstüne makrolu olarak yedekleme yapıyor.
Yapmak istediğim butona bastığımda aynı şekilde makrosuz (.xlsx) uznatılı olarak yedeklemesi için kodun neresinde değişiklik yapmam gerekir.
Yardımcı olur musunuz?

tahsinanarat · 22 Mart 2020

Bu kodları deneyin. Dosyayı aynı isimle makrosuz kaydeder.

Kod:

Sub askm_Makrosuz_Kaydet()
Application.DisplayAlerts = False

    With ThisWorkbook
        .Sheets.Copy
        ActiveWorkbook.SaveAs _
            Filename:=Replace(.FullName, ".xlsm", ".xlsx"), _
            FileFormat:=xlOpenXMLWorkbook
    End With
    ActiveWorkbook.Close False 'xlsx doyayı kapatmak için

End Sub

Sn. @askm nin kodları, arşivimden ekliyorum.

ASLAN7410 · 22 Mart 2020

Sayın Tahsin Bey, ilginiz için çok teşekkür ediyorum.

ASLAN7410 · 22 Mart 2020

Yapmak istediğim dosyayı her açtığımda masaüstündeki YEDEK klasör içerisine aynı anda hem makrolu, hemde makrosuz olarak farklı kaydetmek istiyorum.
Dosya şuan zaten makrolu kaydediyor, birde bunu makrosuz kaydedersem olacak.

yol = yer & "\" & Format(Now, "dd.mm.yyyy hh_nn_ss") & " " & SadeceAd & uzanti

tahsinanarat · 22 Mart 2020

Sn. @ASLAN7410 Bu şekilde deneyin.

Kod:

Sub YedekAlma() 'Butonla
Set ds = CreateObject("Scripting.FileSystemObject")
ThisWorkbook.Save
yer = Environ("USERPROFILE") & "\DESKTOP\YEDEK"
If ds.FolderExists(yer) = False Then
ds.CreateFolder yer
End If
If ThisWorkbook.Path = yer Then Exit Sub
If MsgBox("Dosyanın yedeğini almak istiyor musunuz?", vbInformation + vbYesNo, "A S L A N") = vbNo Then
MsgBox "İptal ettiniz.", vbInformation, "A S L A N"
Exit Sub
End If
dosyaadi = ThisWorkbook.FullName
dosyaadi2 = ThisWorkbook.Name
DosyaUzanti = LCase(Mid(dosyaadi2, InStr(1, dosyaadi2, ".", 1) + 1))
SadeceAd = Mid(dosyaadi2, 1, (Len(dosyaadi2) - Len(DosyaUzanti) - 1))
uzanti = "." & ds.GetExtensionName(dosyaadi)
yol = yer & "\" & Format(Now, "dd.mm.yyyy hh_nn_ss") & " " & SadeceAd & uzanti
ds.CopyFile dosyaadi, yol
Sheets(1).Activate
Range("B" & Sheets(1).[B1048576].End(3).Row + 1).Select

Sheets(ActiveSheet.Name).Copy
Application.DisplayAlerts = False
ActiveSheet.DrawingObjects.Delete
ActiveWorkbook.SaveAs yer & "\" & Format(Now, "dd.mm.yyyy hh_nn_ss") & " " & SadeceAd & ".xlsx", FileFormat:=51
ActiveWindow.Close

MsgBox ("Dosya masaüstündeki YEDEK klasörüne yedeklendi."), vbInformation, "A S L A N"
End Sub

ASLAN7410 · 22 Mart 2020

Sayın Tahsin Bey, ellerinize sağlık çok teşekkür ediyorum, tam istediğim gibi çalışıyor.
Hayırlı günler diliyorum.

Korhan Ayhan · 22 Mart 2020

Alternatif;

C++:

Option Explicit

Sub Yedekle()
    Dim Yol As String, Sayfa As Worksheet
    
    Yol = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\Yedek"
    If Dir(Yol, vbDirectory) = "" Then MkDir (Yol)

    If MsgBox("Dosyanın yedeğini almak istiyor musunuz?", vbInformation + vbYesNo + vbDefaultButton2) = vbNo Then
        MsgBox "İşlemi iptal ettiniz!", vbExclamation
        Exit Sub
    End If
    
    ThisWorkbook.Save
    ThisWorkbook.SaveCopyAs Yol & "\" & Format(Now, "dd.mm.yyyy hh_nn_ss") & " " & ThisWorkbook.Name
    
    ThisWorkbook.Sheets.Copy
    
    For Each Sayfa In ActiveWorkbook.Worksheets
        If Sayfa.DrawingObjects.Count > 0 Then
            Sayfa.DrawingObjects.Visible = True
            Sayfa.DrawingObjects.Delete
        End If
    Next
    
    ActiveWorkbook.SaveAs Yol & "\" & Format(Now, "dd.mm.yyyy hh_nn_ss") & " " & Replace(ThisWorkbook.Name, "xlsm", "xlsx"), 51
    ActiveWorkbook.Close
    
    MsgBox "Dosya masaüstündeki YEDEK klasörüne yedeklendi.", vbInformation
End Sub

anthraxx02 · 22 Mart 2020

tahsinanarat' Alıntı:

Sn. @ASLAN7410 Bu şekilde deneyin.

Kod:

Sub YedekAlma() 'Butonla
Set ds = CreateObject("Scripting.FileSystemObject")
ThisWorkbook.Save
yer = Environ("USERPROFILE") & "\DESKTOP\YEDEK"
If ds.FolderExists(yer) = False Then
ds.CreateFolder yer
End If
If ThisWorkbook.Path = yer Then Exit Sub
If MsgBox("Dosyanın yedeğini almak istiyor musunuz?", vbInformation + vbYesNo, "A S L A N") = vbNo Then
MsgBox "İptal ettiniz.", vbInformation, "A S L A N"
Exit Sub
End If
dosyaadi = ThisWorkbook.FullName
dosyaadi2 = ThisWorkbook.Name
DosyaUzanti = LCase(Mid(dosyaadi2, InStr(1, dosyaadi2, ".", 1) + 1))
SadeceAd = Mid(dosyaadi2, 1, (Len(dosyaadi2) - Len(DosyaUzanti) - 1))
uzanti = "." & ds.GetExtensionName(dosyaadi)
yol = yer & "\" & Format(Now, "dd.mm.yyyy hh_nn_ss") & " " & SadeceAd & uzanti
ds.CopyFile dosyaadi, yol
Sheets(1).Activate
Range("B" & Sheets(1).[B1048576].End(3).Row + 1).Select

Sheets(ActiveSheet.Name).Copy
Application.DisplayAlerts = False
ActiveSheet.DrawingObjects.Delete
ActiveWorkbook.SaveAs yer & "\" & Format(Now, "dd.mm.yyyy hh_nn_ss") & " " & SadeceAd & ".xlsx", FileFormat:=51
ActiveWindow.Close

MsgBox ("Dosya masaüstündeki YEDEK klasörüne yedeklendi."), vbInformation, "A S L A N"
End Sub

merhabalar;

paylaştığınız kod benimde işime yaradı lakin 2 adet sorum olacak
1. butona bastığımızda yedek klasörüne 2adet excel gelmekte 1.si makro içerikli 2.si boş bir excel
2. kayıt yolunu değiştirmek istemekteyim (D:\excel\MAKRO EXCEL) şeklinde

tahsinanarat · 22 Mart 2020

Sn.@ anthraxx02

1.Butona bastığımızda Yedek klasörüne 2 adet excel dosyasını kaydediyor, bir tanesi makro içerebilen yani orjinal dosyayı, ikincisi de .xlsx olarak yani makroları silerek kayıt yapıyor, örnek dosya boş olduğundan boş görünüyor, dosyada bilgiler olsaydı görünürdü.
2. Koddaki;
yer = Environ("USERPROFILE") & "\DESKTOP\YEDEK"
yer = "D:\excel\MAKRO EXCEL" olarak değiştiriniz, sürücünüzde bu klasörün olması gerekli.

Not: Bence Korhan hocamın kodları daha kullanışlı, tavsiyemdir. @Korhan Ayhan Hocam elinize sağlık.

anthraxx02 · 23 Mart 2020

tahsinanarat' Alıntı:
Sn.@ anthraxx02

1.Butona bastığımızda Yedek klasörüne 2 adet excel dosyasını kaydediyor, bir tanesi makro içerebilen yani orjinal dosyayı, ikincisi de .xlsx olarak yani makroları silerek kayıt yapıyor, örnek dosya boş olduğundan boş görünüyor, dosyada bilgiler olsaydı görünürdü.
2. Koddaki;
yer = Environ("USERPROFILE") & "\DESKTOP\YEDEK"
yer = "D:\excel\MAKRO EXCEL" olarak değiştiriniz, sürücünüzde bu klasörün olması gerekli.

Not: Bence Korhan hocamın kodları daha kullanışlı, tavsiyemdir. @Korhan Ayhan Hocam elinize sağlık.

.xlsx olarak kaydetmesini iptal etme şansımız mümkün mü ?

relaxim · 23 Mart 2020

ASLAN7410 sizin örneğinizdeki kodları kendi çalışmama aldım. Masaüstü yerine D ' ye (DEPO) yedeklemek için neresini değiştirmem lazım?

Sub YedekAlma() 'Butonla
Set ds = CreateObject("Scripting.FileSystemObject")
ThisWorkbook.Save
yer = Environ("USERPROFILE") & "\DESKTOP\YEDEK" 'Buraya D ve DEPO yazarak denedim olmadı.
If ds.FolderExists(yer) = False Then
ds.CreateFolder yer
End If
If ThisWorkbook.Path = yer Then Exit Sub
If MsgBox("Dosyanın yedeğini almak istiyor musunuz?", vbInformation + vbYesNo, "A S L A N") = vbNo Then
MsgBox "İptal ettiniz.", vbInformation, "A S L A N"
Exit Sub
End If
DosyaAdi = ThisWorkbook.FullName
dosyaadi2 = ThisWorkbook.Name
DosyaUzanti = LCase(Mid(dosyaadi2, InStr(1, dosyaadi2, ".", 1) + 1))
SadeceAd = Mid(dosyaadi2, 1, (Len(dosyaadi2) - Len(DosyaUzanti) - 1))
uzanti = "." & ds.GetExtensionName(DosyaAdi)
yol = yer & "\" & Format(Now, "dd.mm.yyyy hh_nn_ss") & " " & SadeceAd & uzanti
ds.CopyFile DosyaAdi, yol

Sheets(1).Activate
Range("B" & Sheets(1).[B1048576].End(3).Row + 1).Select

MsgBox ("Dosya masaüstündeki YEDEK klasörüne yedeklendi."), vbInformation, "A S L A N"
End Sub

Korhan Ayhan · 23 Mart 2020

Aşağıdaki gibi deneyiniz.

yer = "D:\DEPO\YEDEK"

relaxim · 23 Mart 2020

Korhan hocam merhaba,
Yol bulunamadı hatası veriyor.
Şunu belirtmeyi unuttum. Dosya ana bilgisayarda Ortak Belgeler klasörünün içinde
Aslan7410 nun kod ile masa üstüne yedek alabiliyorum. İstedim ki D sürücüsüne yedek alayım orası biraz daha güvenli olur.

tahsinanarat · 23 Mart 2020

Sn. @anthraxx02 makrosuz kayıt yapmasını istemiyorsanız aşağıda belirtilen satırları siliniz.

Sheets(ActiveSheet.Name).Copy
Application.DisplayAlerts = False
ActiveSheet.DrawingObjects.Delete
ActiveWorkbook.SaveAs yer & "\" & Format(Now, "dd.mm.yyyy hh_nn_ss") & " " & SadeceAd & ".xlsx", FileFormat:=51
ActiveWindow.Close

relaxim · 23 Mart 2020

Korhan Ayhan' Alıntı:

Alternatif;

C++:

Option Explicit

Sub Yedekle()
    Dim Yol As String, Sayfa As Worksheet
   
    Yol = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\Yedek"
    If Dir(Yol, vbDirectory) = "" Then MkDir (Yol)

    If MsgBox("Dosyanın yedeğini almak istiyor musunuz?", vbInformation + vbYesNo + vbDefaultButton2) = vbNo Then
        MsgBox "İşlemi iptal ettiniz!", vbExclamation
        Exit Sub
    End If
   
    ThisWorkbook.Save
    ThisWorkbook.SaveCopyAs Yol & "\" & Format(Now, "dd.mm.yyyy hh_nn_ss") & " " & ThisWorkbook.Name
   
    ThisWorkbook.Sheets.Copy
   
    For Each Sayfa In ActiveWorkbook.Worksheets
        Sayfa.DrawingObjects.Visible = True
        Sayfa.DrawingObjects.Delete
    Next
   
    ActiveWorkbook.SaveAs Yol & "\" & Format(Now, "dd.mm.yyyy hh_nn_ss") & " " & Replace(ThisWorkbook.Name, "xlsm", "xlsx"), 51
    ActiveWorkbook.Close
   
    MsgBox "Dosya masaüstündeki YEDEK klasörüne yedeklendi.", vbInformation
End Sub

Hocam sadece D ye xlsm olarak kaydedecek şekilde düzenleyebilir miyiz?

saygılarımla.

Korhan Ayhan · 23 Mart 2020

Eğer "D" klasörüne yeni dosya oluşturma yetkiniz yoksa kod hata verebilir.

C++:

Option Explicit

Sub Yedekle()
    Dim Yol As String, Sayfa As Worksheet
   
    Yol = "D:\Yedek"
    If Dir(Yol, vbDirectory) = "" Then MkDir (Yol)

    If MsgBox("Dosyanın yedeğini almak istiyor musunuz?", vbInformation + vbYesNo + vbDefaultButton2) = vbNo Then
        MsgBox "İşlemi iptal ettiniz!", vbExclamation
        Exit Sub
    End If
   
    ThisWorkbook.Save
    ThisWorkbook.SaveCopyAs Yol & "\" & Format(Now, "dd.mm.yyyy hh_nn_ss") & " " & ThisWorkbook.Name
   
    MsgBox "Dosya D:\Yedek klasörüne yedeklendi.", vbInformation
End Sub

relaxim · 23 Mart 2020

Korhan Hocam ellerine sağlık oldu. Problem çıkartmadı. Allah razı olsun. Saygılar...

TURKOLOG · 23 Mart 2020

Kod:

Private Sub Makrolu_Makrosuz_Yedek_Click()

Dim Yol As String, Sayfa As Worksheet

   

    Yol = Sheets("SABİTLER").[B27].Text

    isim = Sheets("SABİTLER").[B26].Text

    If Dir(Yol, vbDirectory) = "" Then MkDir (Yol)

 

    If MsgBox("Dosyanın yedeğini almak istiyor musunuz?", vbInformation + vbYesNo + vbDefaultButton2) = vbNo Then

        MsgBox "İşlemi iptal ettiniz!", vbExclamation

        Exit Sub

    End If

   

    ThisWorkbook.Save

    ThisWorkbook.SaveCopyAs Yol & "" & isim & "" & Format(Now, "dd.mm.yyyy hh_nn_ss") & " " & ThisWorkbook.Name

   

    ThisWorkbook.Sheets.Copy

   

    For Each Sayfa In ActiveWorkbook.Worksheets

        Sayfa.DrawingObjects.Visible = True

        Sayfa.DrawingObjects.Delete

    Next

   

    ActiveWorkbook.SaveAs Yol & "" & isim & "" & Format(Now, "dd.mm.yyyy hh_nn_ss") & " " & Replace(ThisWorkbook.Name, "xlsm", "xlsx"), 51

    ActiveWorkbook.Close

   

    MsgBox "Dosya masaüstündeki YEDEK klasörüne yedeklendi.", vbInformation

 

End Sub

Sayfa.DrawingObjects.Visible = True bu kısımda hata veriyor ve sadece makrolu kayıt yapıyor.

ASLAN7410 · 23 Mart 2020

7.mesajınızdaki kod için çok teşekkür ederim, Korhan Bey ellerinize sağlık, hayırlı günler diliyorum.

Korhan Ayhan · 23 Mart 2020

@TURKOLOG hata veren bölüm kopyalanan dosyada bulunan butonları silen koddur. Üstteki (#7) mesajıma küçük bir ekleme yaptım. Son halini deneyiniz.

Dosya yedekleme

ASLAN7410

Ekli dosyalar

tahsinanarat

ASLAN7410

ASLAN7410

tahsinanarat

ASLAN7410

Korhan Ayhan

Administrator

anthraxx02

tahsinanarat

anthraxx02

relaxim

Korhan Ayhan

Administrator

relaxim

tahsinanarat

relaxim

Korhan Ayhan

Administrator

relaxim

TURKOLOG

ASLAN7410

Korhan Ayhan

Administrator