Aylık dosya yedekleme

[Kavinsky]

Merhabalar benim 5 adet çalışma kitabım var ve her birinin içinde ayrı veriler var. Verileri ise formülle hesaplanıyor. Benim amacım şudur,

Excel dosyası isimleri;

Veri1
Veri2
Veri3
Veri4
Veri5

5 adet dosyayı sırayla açıp her dosyada şu işlemi yapsın;
Mevcut formüllü verileri kopyalayıp sadece düz veri olarak aynı yerlerine yapıştırıp farklı kaydetsin ve mevcuttaki dosyada herhangi bir işlem yapmasın.
Farklı kaydet bittikten sonra Mevcut dosyaya dönüp dosyada ise SIFIRLA isimli makroyu çalıştırıp o ay girilen verileri sıfırlasın ve ardından kaydetsin.

Böylelikle her ay ben bu makroyu çalıştırdığımda formüllü dosyaları verili dosyaya çevirerek yedek almış olacağım.
Formülle kopyalarsam hala veri almaya devam edecek çünkü. O sebeple yedeklediğim dosyada formül olayını iptal ediyorum.

İşin içinden çıkamadım, yardımlarınızı rica ediyorum.

 

[bmutlu966]

Dosyalarınızın her sayfasını formüllerden kurtarır ve dosyalarınızn bulunduğu klasörün altında açacağınız Yedekle adlı klasöre aynı ad ile ve tarih ve saat yazarak yedekler.

https://dosya.co/nqbqvza7xsmn/Dosya_Yedekle.xlsm.html

Sub Yedekle()

Dosyalarin_bulundugu_klasoru_sec

Application.ScreenUpdating = False

If [BM1] = "" Then End

yedekler = [BM1] & "\Yedekler"

Dim t, dosyasay As Integer
Dim fso As Object, f As Object, dosya As String, kaynak As String, fls As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set f = fso.getfolder([BM1]).Files

dosyasay = 0

For Each fls In f
    If fso.GetExtensionName(fls) = "xlsx" Then 'Veri dosyalarınız makro içeriyorsa bu bölümü "xlsm" yapınız.
      
        Workbooks.Open (fls)
      
        For t = 1 To Sheets.Count
        Sheets(t).Select
           Cells.Copy
           Cells.PasteSpecial xlValues
           Range("A1").Select

        Next t
      
        dosya = yedekler & "\" & Format(Now, "dd.mm.yyy hh.ss") & "_" & ActiveWorkbook.Name
        ActiveWorkbook.SaveAs Filename:=dosya
        ActiveWorkbook.Close True
      
      
        dosyasay = dosyasay + 1

    End If
Next fls
ThisWorkbook.Activate

Application.ScreenUpdating = True
MsgBox dosyasay & " adet dosyadaki bilgiler yedeklendi."


End Sub

Sub Dosyalarin_bulundugu_klasoru_sec()
Dim kaynak As String
[BM1].Clear
Set Klasor = CreateObject("shell.application").BrowseForFolder(0, "Veri Dosyalarinin bulundugu Klasoru Secin", 50, &H0)
If Not Klasor Is Nothing Then
kaynak = Klasor.SELF.Path 'Klasor.Items.Item.Path
[BM1] = kaynak

End If
End Sub

 

[Kavinsky]

bmutlu966 hocam öncelikle çok teşekkür ederim fakat tam istediğimi vermedi kodlar. Özetlemem gerekirse;

Z:\data\30_URETIM_ORTAK\01_ÜRETİM_RAPOR\VERİ

Bu yoldaki verileri

Z:\data\30_URETIM_ORTAK\01_ÜRETİM_RAPOR\ARŞİV

bu yolun altına önce mevcut yılın klasörü ardından mevcut ayın isminin yazdığı klasörüne atmasını istiyorum.

Bendeki kod aşağıdaki gibidir, Bu kod formülleri verilere dönüştürüp yedekleme klasör yolunda kaydediyor lakin
Mevcut dosyada Call SıfırlaDevamsızlık çalıştırıp ardından kaydedip dosyayı kapatmıyor öylece bırakıyor. O konuda takıldım esasında.

Sub YedekleDevamsızlık()
    Dim My_Folder As String
  
    Call RepairDevamsızlık
  
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
  
     My_Folder = "Z:\data\30_URETIM_ORTAK\01_ÜRETİM_RAPOR\ARŞİV\" & Format(Date, "yyyy") & "\" & Format(Date, "mmmm") & "\"


    If Dir(My_Folder, vbDirectory) = "" Then
        Shell ("cmd /c mkdir """ & My_Folder & """")
    End If
    ThisWorkbook.Sheets.Copy
  
    ActiveWorkbook.SaveAs My_Folder & Replace(ThisWorkbook.Name, "xlsm", "xlsx"), 51
    ActiveWorkbook.Close
  

  
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
Call SıfırlaDevamsızlık
ThisWorkbook.Save
Application.Quit
End Sub

 

[Korhan Ayhan]

Denemek için paylaştığınız kodda aşağıdaki iki satırı pasif yaptım.

Call RepairDevamsızlık
Call SıfırlaDevamsızlık

Sorun çıkmadan dosyanın yedeği oluştu ve dosya kapandı. Demek ki bu kodların birinde bahsettiğiniz durumu yaratan bir sorun var. Bunları irdelemenizi tavsiye ederim.

 

[Kavinsky]

@Korhan Ayhan hocam merhaba zaten bu kodlar için sizden yardım almıştım.
Denem yaptığınızda formülleri veriye çevirip farklı kaydedip ardından orjinal dosyaya dönüp kaydedip kapattı mı ?

Bahsettiğiniz kodlar aşağıda lakin ben işin içinden çıkamadım.
Sizden de bu hususta yardım rica edebilir miyim ?

Sub SıfırlaDevamsızlık()

Sheets("VARDİYA A").Select
    ActiveSheet.Unprotect
    Range("E3:G33,I3:V33,Z3:AI33,AL3:AL33").Select
    Range("AL33").Activate
    Selection.ClearContents
    ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True

Sheets("VARDİYA B").Select
    ActiveSheet.Unprotect
    Range("E3:G33,I3:V33,Z3:AI33,AL3:AL33").Select
    Range("AL33").Activate
    Selection.ClearContents
    ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
   
Sheets("VARDİYA C").Select
    ActiveSheet.Unprotect
    Range("E3:G33,I3:V33,Z3:AI33,AL3:AL33").Select
    Range("AL33").Activate
    Selection.ClearContents
    ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
 
Sheets("VARDİYA A").Select
Range("E3").Select
End Sub

Sub RepairDevamsızlık()

Sheets("VARDİYA A").Select
ActiveSheet.Unprotect

Range("A1:AL35").Select
Selection.Copy
Range("A1:AL35").Select
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
    Cells.Select
    Cells.EntireRow.AutoFit
    Range("H13").Select


Sheets("VARDİYA B").Select
ActiveSheet.Unprotect

Range("A1:AL35").Select
Selection.Copy
Range("A1:AL35").Select
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
    Cells.Select
    Cells.EntireRow.AutoFit
    Range("H13").Select
   
   
Sheets("VARDİYA C").Select
ActiveSheet.Unprotect

Range("A1:AL35").Select
Selection.Copy
Range("A1:AL35").Select
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
    Cells.Select
    Cells.EntireRow.AutoFit
    Range("H13").Select
   

        Sheets("VARDİYA A").Select
    ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
        Sheets("VARDİYA B").Select
    ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
        Sheets("VARDİYA C").Select
    ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True

   
Sheets("VARDİYA A").Select
Range("H13").Select

End Sub

 

[Korhan Ayhan]

Verdiğiniz kodları boş bir dosyada denedim. (Sayfa isimlerini sizin kodlardaki gibi düzenledim.)

Makro sorun çıkmadan çalıştı.

 

[Kavinsky]

Hocam senaryo şöyle mi oldu;
Orjinal dosyadaki formüllü verileri kopyala yapıştır ile formülsüz normal veriye dönüştürdü ve farklı kaydetti.
Ardından orjinal dosyaya geri döndü ve elle girilen verileri sıfırlayarak formülleri de olduğu gibi bırakarak kaydetti ve kapattı mı ?

 

[Korhan Ayhan]

Şöyle uyguladım...

Boş bir excel dosyası açtım.
İçine 3 sayfa ekledim. (VARDİYA A / VARDİYA B / VARDİYA C)
Bu sayfalar boş durumdaydı.
Sonra içlerine rastgele birşeyler yazdım. Veri olması açısından..
Sonra dosya yolunu masaüstü olacak şekilde ayarladım. Malum sizin dosya yolu bende yok.
Son olarak kodu çalıştırdım ve sorunsuz çalıştı.

 

[Kavinsky]

Değerli hocam dosyaları upload ettim.

Easyupload.io - Upload Files and Share Them Easily

Uplaod files easily and share them with your friends and colleagues. File upload solution for everyone. Upload big files and get a link to share effortlesly.

easyupload.io

İsteğim şunlar;

• mevcut olan dosyada YEDEKLE isimli makro mevcut.
• Dosyadaki formülleri normal veriye çevirsin ( yani kendini güncellemesin ya da bağlı olduğu dosyadan veri çekmesin) Onda problem yok gibi gözüküyor formülleri kopyalayıp veri olarak yapıştırıyor.
• Yedekle makrosunda belirlenen yere farklı kaydetsin ve kapatsın. (Bunu da yapıyor)
• Ardından orjinal dosyaya dönüp SIFIRLA isimli makroyu çalıştırsın ve formüllü halde kaydetsin. (Problem burada)

Verimlilik dosyası devamsızlık dosyasından veri çekiyor hocam.

Ben işin içinden çıkamadım veri olarak farklı kaydedip dosyayı kapatıyor. Orjinal dosyaya dönünce istediklerimi yapmıyor sıfırlamadan kaydedip kapatıyor.

 

[Korhan Ayhan]

Aşağıdaki gibi deneyiniz.

En altta pasif hale getirdiğim komut excel uygulamasını kapatıyor. İhtiyacınız bu yönde ise satırın başındaki tek tırnak sembolünü silerek aktif hale getirebilirsiniz. İhtiyacınız yoksa o satırı komple silebilirsiniz.

Option Explicit

Sub YedekleDevamsızlık()
    Dim My_Folder As String
   
    ThisWorkbook.Sheets.Copy
   
    Call RepairDevamsızlık
   
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
   
    My_Folder = "Z:\data\30_URETIM_ORTAK\01_ÜRETİM_RAPOR\ARŞİV\" & Format(DateAdd("m", -1, Date), "yyyy") & "\" & Format(DateAdd("m", -1, Date), "mmmm") & "\"

    If Dir(My_Folder, vbDirectory) = "" Then
        Shell ("cmd /c mkdir """ & My_Folder & """")
    End If
   
    ActiveWorkbook.SaveAs My_Folder & Replace(ThisWorkbook.Name, "xlsm", "xlsx"), 51
    ActiveWorkbook.Close
   
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
   
    Call SıfırlaDevamsızlık
    ThisWorkbook.Save
'    Application.Quit
End Sub

 

[Kavinsky]

Değerli hocam çok teşekkür ederim. Hemen deneyeceğim.
Peki malumunuz mevcut ayın ismine göre klasöre atıyor. Bunu 1 ay öncesinin klasörüne atması mümkün mü ?
Şubat ayında çalıştıracağım ama malumunuz ocak ayının verisi bunlar.
Mümkünmüdür bu şekilde isimlendirmek?

 

[Korhan Ayhan]

Üstte ki mesajımdaki kodda bahsettiğiniz revizeyi yaptım.

Yaptığım revize içinde bulunulan aydan bir önceki ayı bularak işlem yapıyor. Yani dikkatli kullanmanız gerekir. 2023 Ocak ayında kod çalıştırırsanız 2022 Aralık olarak yedekler.