- Katılım
- 15 Mart 2005
- Mesajlar
- 41,510
- Excel Vers. ve Dili
- Microsoft 365 Tr-En 64 Bit
Merhaba,
Bende ilk mesajınızdaki dosyada denemiştim ve olumlu sonuç aldım. Eğer sizin uyguladığınız dosyada sayfalarda formül ve koşullu biçimlendirme yoksa hata vermesi normaldir. Koda hata kontrolleri eklemek gerekecektir.
Hata kontrolleri eklenmiş kodu deneyebilirsiniz.
Bende ilk mesajınızdaki dosyada denemiştim ve olumlu sonuç aldım. Eğer sizin uyguladığınız dosyada sayfalarda formül ve koşullu biçimlendirme yoksa hata vermesi normaldir. Koda hata kontrolleri eklemek gerekecektir.
Hata kontrolleri eklenmiş kodu deneyebilirsiniz.
Kod:
Option Explicit
Sub Formulsuz_ve_Makrosuz_Yedek_Olustur()
Dim K1 As Workbook, Yedek As Workbook, Sayfa As Worksheet
Dim Grafik As ChartObject, Alan As Range, Yol As String, Dosya_Adi As String
Dim Formul As Variant, Kosullu_Bicimlendirme As Variant
Application.Calculate
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
.DisplayAlerts = False
.EnableEvents = False
End With
Set K1 = ThisWorkbook
K1.Sheets.Copy
Set Yedek = ActiveWorkbook
For Each Sayfa In Yedek.Worksheets
If Sayfa.Name <> "ÖNBİLGİ" Then
For Each Grafik In Sayfa.ChartObjects
If Sheets("ÖNBİLGİ").Range("F4").Value = "" Then
Grafik.Chart.ChartTitle.Caption = ""
Else
Grafik.Chart.ChartTitle.Caption = Sheets("ÖNBİLGİ").Range("F4").Value
End If
Next
Set Formul = Nothing
On Error Resume Next
Set Formul = Sayfa.Cells.SpecialCells(xlCellTypeFormulas)
On Error GoTo 0
If Not Formul Is Nothing Then
With Sayfa
.Select
.Cells.Copy
.Cells.PasteSpecial xlPasteValues
.Cells(1).Select
End With
Application.CutCopyMode = False
End If
Set Kosullu_Bicimlendirme = Nothing
On Error Resume Next
Set Kosullu_Bicimlendirme = Sayfa.Cells.SpecialCells(xlCellTypeAllFormatConditions)
On Error GoTo 0
If Not Kosullu_Bicimlendirme Is Nothing Then
For Each Alan In Kosullu_Bicimlendirme
Alan.Interior.ColorIndex = Alan.DisplayFormat.Interior.ColorIndex
Alan.Font.ColorIndex = Alan.DisplayFormat.Font.ColorIndex
Next
Sayfa.Cells.FormatConditions.Delete
End If
End If
Next
Yedek.Sheets("ÖNBİLGİ").Delete
Yedek.Sheets(1).Select
Yol = K1.Path & Application.PathSeparator
Dosya_Adi = "Yedek_" & Format(Date, "dd_mm_yy") & "_" & Format(Time, "hh_mm_ss") & ".xlsx"
Yedek.SaveCopyAs Yol & Dosya_Adi
Yedek.Close False
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
.DisplayAlerts = True
.EnableEvents = True
End With
MsgBox "Dosyanız aşağıdaki klasöre formülsüz ve makrosuz olarak yedeklenmiştir." & vbCrLf & vbCrLf & _
Yol & Dosya_Adi, vbInformation
End Sub
