Farklı Kaydet Kod Yardımı

[fırat_raman]

Merhaba arkadaşlar,
Aşağıya eklediğim kod aktif sayfayı farklı kayıt ediyor. Ben bu kodun aktif sayfayı formülsüz, makrosuz ve butonsuz kayıt etmesini istiyorum. Ayrıca sayfa isimi ile kayıt etmesini istiyorum. Yardım ederseniz sevinirim. İyi çalışmalar dilerim.

Private Sub CommandButton1_Click()
Kayıt_Yeri = "C:\YEDEK\"
On Error Resume Next
If Dir(Kayıt_Yeri) = "" Then MkDir Kayıt_Yeri
On Error Resume Next
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim Sourcewb As Workbook
Dim Destwb As Workbook
Dim TempFilePath As String
Dim TempFileName As String

With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set Sourcewb = ActiveWorkbook
ActiveSheet.Copy
Set Destwb = ActiveWorkbook
With Destwb
If Val(Application.Version) < 12 Then
FileExtStr = ".xls": FileFormatNum = -4143
Else
If Sourcewb.Name = .Name Then
With Application
.ScreenUpdating = True
.EnableEvents = True
.DisplayAlerts = False
End With
MsgBox "Your answer is NO in the security dialog"
Exit Sub
Else
Select Case Sourcewb.FileFormat
Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
Case 52:
If .HasVBProject Then
FileExtStr = ".xlsm": FileFormatNum = 52
Else
FileExtStr = ".xlsx": FileFormatNum = 51
End If
Case 56: FileExtStr = ".xls": FileFormatNum = 56
Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
End Select
End If
End If
End With
TempFilePath = Kayıt_Yeri 'Application.DefaultFilePath & "\"
TempFileName = Sourcewb.Name & " " & Format(Now, "dd_mm_yyyy_hh_mm_ss")
With Destwb
.SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
.Close SaveChanges:=False
End With
MsgBox "Dosyanız aşağıdaki isimle yedeklenmiştir." & Chr(10) & TempFileName, vbInformation, "Ajandam Uyarı Sistemi"
With Application
.ScreenUpdating = True
.EnableEvents = True
End With

End Sub

 

[Mertsan]

Merhaba,

Yabancı bir kaynaktan şöyle bir kod buldum.

Sub MacrosuzFormulsuzFarkliKaydet()
    Dim w As Long
    For w = 1 To Sheets.Count
        Sheets(w).UsedRange = Sheets(w).UsedRange.Value
    Next w
    Application.DisplayAlerts = False
    ThisWorkbook.SaveAs _
      ThisWorkbook.Path & Chr(92) & _
        Left(ThisWorkbook.Name, InStr(1, ThisWorkbook.Name, Chr(46)) - 1) & Format(Date, "_yyyy-mm"), _
      xlOpenXMLWorkbook
End Sub

Mevcut dosya ismine günün tarihini ekleyerek formülsüz ve makrosuz olarak kaydediyor.

 

[fırat_raman]

Merhaba,

Yabancı bir kaynaktan şöyle bir kod buldum.

Sub MacrosuzFormulsuzFarkliKaydet()
    Dim w As Long
    For w = 1 To Sheets.Count
        Sheets(w).UsedRange = Sheets(w).UsedRange.Value
    Next w
    Application.DisplayAlerts = False
    ThisWorkbook.SaveAs _
      ThisWorkbook.Path & Chr(92) & _
        Left(ThisWorkbook.Name, InStr(1, ThisWorkbook.Name, Chr(46)) - 1) & Format(Date, "_yyyy-mm"), _
      xlOpenXMLWorkbook
End Sub

Mevcut dosya ismine günün tarihini ekleyerek formülsüz ve makrosuz olarak kaydediyor.

Sn Mertsan,
Öncelikle ilginizden dolayı teşekkür ederim. Vermiş olduğunuz kodu ben daha önce denemiştim. Bu kod sayfayı değil dosyayı tümden kaydetmeye yarıyor. Benim istediğim çalışma sayfasını formülsüz ve makrosuz kaydetmesidir. Yinede teşekkürler.

 

[PLİNT]

Merhaba
Aşağıdaki gibi denermisiniz?

Private Sub CommandButton2_Click()
Dim FileExtStr As String
Dim ds, a, b
Set ds = CreateObject("Scripting.FileSystemObject")
a = ds.FolderExists("C:\" & "\" & "YEDEK")
If a = False Then
MsgBox "klasör yok YEDEK adıyla oluşturulacak "
ds.CreateFolder "C:\" & "\" & "YEDEK"
MsgBox "YEDEK KLASÖRÜ OLUŞTURULDU"
End If
If Val(Application.Version) < 12 Then
FileExtStr = ".xls": FileFormatNum = -4143
Else
FileExtStr = ".xlsx": FileFormatNum = 51
End If
Application.DisplayAlerts = False
Application.ScreenUpdating = False
ChDir "C:\YEDEK\"
kayıt = CreateObject("wscript.Shell").SpecialFolders.Item(ThisWorkbook.Path & "C:\YEDEK\") & _
 ActiveSheet.Name & FileExtStr: ActiveSheet.Copy
For Each s In ActiveSheet.Shapes
ActiveSheet.Shapes.Range(s.Name).Delete
Next
ActiveWorkbook.ActiveSheet.UsedRange.Value = ActiveWorkbook.ActiveSheet.UsedRange.Value
ActiveWorkbook.SaveAs Filename:=kayıt, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
ActiveWorkbook.Close
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Set ds = Nothing
kayıt = Empty
MsgBox "YEDEK KLASÖRÜ İÇİNE SAYFA KAYDEDİLDİ"
End Sub

İlk mesajınıza göre; yedek klasörü içindeki; eski, aynı adlı dosya değişecek

 

[fırat_raman]

Sn PLİNT, vermiş olduğunuz kod işime yaradı. Çok teşekkürler, iyi çalışmalar dilerim.