Değerler şeklinde yedek almak

[anthraxx02]

merhabalar;

aşağıdaki gibi bir makro var stabil çalışmakta lakin eklemek isteğim küçük bir özellik var belirtilen bir klasör'e kayıt yapmak istiyorum aşağıdaki kod excelin yükl olduğu yerin yanına kaydediyor ben misal D:\excel gibi bir dosyaya üreterek içine kaydetmesini istiyorum.Yardım ederseniz Sevinirim


Private Sub CommandButton10_Click()
Application.ScreenUpdating = False
Sayfa4.Cells.Copy
Workbooks.Add 1
Set y = ActiveWorkbook.Sheets(1)
y.[A1].PasteSpecial Paste:=xlPasteValues
y.[A1].EntireRow.Delete
Application.DisplayAlerts = False
y.SaveAs Filename:=ThisWorkbook.Path & "\ Fiyat Güncelleme.xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
Application.DisplayAlerts = True
ActiveWorkbook.Close
Application.CutCopyMode = False
MsgBox " Fiyat Güncelleme.xlsx adıyla kaydedildi.!!!"
End Sub

 

[metin_0606]

merhabalar;

aşağıdaki gibi bir makro var stabil çalışmakta lakin eklemek isteğim küçük bir özellik var belirtilen bir klasör'e kayıt yapmak istiyorum aşağıdaki kod excelin yükl olduğu yerin yanına kaydediyor ben misal D:\excel gibi bir dosyaya üreterek içine kaydetmesini istiyorum.Yardım ederseniz Sevinirim


Private Sub CommandButton10_Click()
Application.ScreenUpdating = False
Sayfa4.Cells.Copy
Workbooks.Add 1
Set y = ActiveWorkbook.Sheets(1)
y.[A1].PasteSpecial Paste:=xlPasteValues
y.[A1].EntireRow.Delete
Application.DisplayAlerts = False
y.SaveAs Filename:=ThisWorkbook.Path & "\ Fiyat Güncelleme.xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
Application.DisplayAlerts = True
ActiveWorkbook.Close
Application.CutCopyMode = False
MsgBox " Fiyat Güncelleme.xlsx adıyla kaydedildi.!!!"
End Sub

C:\ YEDEK isimli klasörün içerisine Çalışma kitabınızı kaydeder

Sub AKTİF_DOSYAYI_YEDEKLE()
    Dim DosyaSistemi As Object, Aktif_Dosya_Adı As String
    Dim Yedek_Dosya_Adı As String, Kayıt_Yeri As String
 
    Set DosyaSistemi = CreateObject("Scripting.FileSystemObject")
    Aktif_Dosya_Adı = ThisWorkbook.FullName
    Yedek_Dosya_Adı = Replace(ThisWorkbook.Name, ".xlsm", "") & Format(Date, " dd_mm_yyyy") & "_" & Format(Now, "hh_mm") & ".xlsm"
 
    Kayıt_Yeri = "C:\YEDEK\" & Yedek_Dosya_Adı
 
    ThisWorkbook.Save
 
    On Error Resume Next
    If Dir("C:\YEDEK\") = "" Then MkDir "C:\YEDEK\"
    DosyaSistemi.CopyFile Aktif_Dosya_Adı, Kayıt_Yeri
 
    MsgBox "Dosyanız aşağıdaki isimle yedeklenmiştir." & Chr(10) & Kayıt_Yeri, vbInformation
End Sub

 

[PLİNT]

Merhaba
Aşağıdaki kodları denermisiniz?

Private Sub CommandButton10_Click()
Application.ScreenUpdating = False
Sayfa4.Cells.Copy
Workbooks.Add 1
Set y = ActiveWorkbook.Sheets(1)
y.[A1].PasteSpecial Paste:=xlPasteValues
y.[A1].EntireRow.Delete
Application.DisplayAlerts = False
yol = "D:\EXCEL"
If Dir(yol, vbDirectory) = Empty Then MkDir yol
ChDir yol
y.SaveAs Filename:=yol & "\Fiyat Güncelleme.xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
Application.DisplayAlerts = True
ActiveWorkbook.Close
Application.CutCopyMode = False
MsgBox " Fiyat Güncelleme.xlsx adıyla kaydedildi.!!!"
End Sub

 

[anthraxx02]

Merhaba
Aşağıdaki kodları denermisiniz?

Private Sub CommandButton10_Click()
Application.ScreenUpdating = False
Sayfa4.Cells.Copy
Workbooks.Add 1
Set y = ActiveWorkbook.Sheets(1)
y.[A1].PasteSpecial Paste:=xlPasteValues
y.[A1].EntireRow.Delete
Application.DisplayAlerts = False
yol = "D:\EXCEL"
If Dir(yol, vbDirectory) = Empty Then MkDir yol
ChDir yol
y.SaveAs Filename:=yol & "\Fiyat Güncelleme.xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
Application.DisplayAlerts = True
ActiveWorkbook.Close
Application.CutCopyMode = False
MsgBox " Fiyat Güncelleme.xlsx adıyla kaydedildi.!!!"
End Sub

teşekkür ederim sorunsuz çalışmaktadır