yedekleme

[zipir123]

Bir butona atadığım aşağıdaki kod ile sadece sayfa1'i yedekleyebiliyorum
Ancak ben o kitap içinde bulunan tüm sayfalarıSayfa 1'in a1 hücresinde yazan değer isminde yedeklemek istiyorum. Bunu nasıl yapabilirim. Teşekkür ederim.

Sub sayfayedekle()
Dim i As String
On Error Resume Next
Application.ScreenUpdating = False
MkDir ("d:\" & "adil")
If ActiveSheet.Range("a1").Value <> "" Then
i = ActiveSheet.Range("a1").Value
Sheets("Sayfa1").Select
Sheets("Sayfa1").Copy
ActiveWorkbook.SaveAs Filename:= _
"d:\adil\" & i & ".xls", _
FileFormat:=xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _
CreateBackup:=False
Workbooks(i & ".xls").Activate
ActiveWindow.View = xlPageBreakPreview
ActiveSheet.Shapes("Button 11").Select
Selection.Delete
ActiveSheet.Shapes("A Grubu").Select
Selection.Delete
ActiveWindow.View = xlNormalView
ActiveWorkbook.Save
ActiveWorkbook.Close
' ThisWorkbook.Close
Application.ScreenUpdating = True
Else: Exit Sub
End If
End Sub

 

[halit3]

Bir butona atadığım aşağıdaki kod ile sadece sayfa1'i yedekleyebiliyorum
Ancak ben o kitap içinde bulunan tüm sayfalarıSayfa 1'in a1 hücresinde yazan değer isminde yedeklemek istiyorum. Bunu nasıl yapabilirim. Teşekkür ederim.

Sub sayfayedekle()
Dim i As String
On Error Resume Next
Application.ScreenUpdating = False
MkDir ("d:\" & "adil")
If ActiveSheet.Range("a1").Value <> "" Then
i = ActiveSheet.Range("a1").Value
Sheets("Sayfa1").Select
Sheets("Sayfa1").Copy
ActiveWorkbook.SaveAs Filename:= _
"d:\adil\" & i & ".xls", _
FileFormat:=xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _
CreateBackup:=False
Workbooks(i & ".xls").Activate
ActiveWindow.View = xlPageBreakPreview
ActiveSheet.Shapes("Button 11").Select
Selection.Delete
ActiveSheet.Shapes("A Grubu").Select
Selection.Delete
ActiveWindow.View = xlNormalView
ActiveWorkbook.Save
ActiveWorkbook.Close
' ThisWorkbook.Close
Application.ScreenUpdating = True
Else: Exit Sub
End If
End Sub

bunu denermisiniz.

Sub farklı_kayıtet()
On Error Resume Next
Dim Baslik As String
Baslik = "Kaynak Dosyaları İçeren Klasörü Seçin"
Set Obj = CreateObject("shell.application")
Set Klasor = Obj.BrowseForFolder(0, Baslik, 50, &H0)
kaynak = Klasor.items.Item.Path
If Len(kaynak) = 3 Then
kaynak = Mid(kaynak, 1, 2)
Else
kaynak = kaynak
End If

If Not Klasor Is Nothing Then
If InStr(1, kaynak, "{") > 0 Then GoTo Atla
On Error Resume Next
deger = InputBox("UYARI!" & Chr(10) & _
Chr(10) & "  Yeni Dosyanın adını yazınız " & Chr(10) & Chr(10) & _
"", _
"DİKKAT !", "", , , "DEMO.HLP", 10)
kayıt = MsgBox(deger & " olarak Farklı kayıt etmek istiyormusunuz. ?", vbYesNo)
If kayıt = vbYes Then
Dim DosyaSistemi
Set DosyaSistemi = CreateObject("Scripting.FileSystemObject")
Dosya = ThisWorkbook.FullName
kayıt_yeri = kaynak & "\" & deger & ".xls"
On Error Resume Next
If deger <> "" Then
DosyaSistemi.CopyFile Dosya, kayıt_yeri
Else
MsgBox "DOSYA ADI YAZILI DEĞİL"
End If
End If
ActiveWindow.WindowState = xlMaximized
Else
Atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If
End Sub

 

[zipir123]

Sn. Halit3 sizin kodlarınızı denedim gayet güzel çalışıyor. Ancak kodlar çok fazla yönlendirme yapıyor.İlginize teşekkür ederim. Benim istediğim tek bir tuşla bütün bu işlemleri yönlendirme yapmadan yapabilmek
Ekli dosyayı incelediğinizde daha iyi anlayacaksınız.

 

[halit3]

Sn. Halit3 sizin kodlarınızı denedim gayet güzel çalışıyor. Ancak kodlar çok fazla yönlendirme yapıyor.İlginize teşekkür ederim. Benim istediğim tek bir tuşla bütün bu işlemleri yönlendirme yapmadan yapabilmek
Ekli dosyayı incelediğinizde daha iyi anlayacaksınız.

bunu denermisiniz

Sub Düğme172_Tıklat()
Dim DosyaSistemi
Set DosyaSistemi = CreateObject("Scripting.FileSystemObject")
Dosya = ThisWorkbook.FullName
kayıt_yeri = "D:\günlük görevler\" & Cells(4, 6).Value & ".xls"
On Error Resume Next
DosyaSistemi.CopyFile Dosya, kayıt_yeri
End Sub

 

[zipir123]

Sn. Halit3 ilginize çok teşekkür ederim. Problem sayenizde çözüldü.

 

[halit3]

Sn. Halit3 ilginize çok teşekkür ederim. Problem sayenizde çözüldü.

hayırlı işler iyi çalışmalar diliyorum