Klasör oluşturma ve bu klasör içine belgenin yedeğini kopyalama.

[Halit TÜRK]

Sayın Korhan bey yardımınız için çok teşekkürler...
Zannederim kendi dosyama da uygulayabilirim. Sadece bir bilgi vermek istiyorum, ikinci kez kayıt yapılırsa işlem bekletiyor. Tekrar teşekkürler...

 

[Korhan Ayhan]

Selamlar,

Üstteki mesajımı güncelledim. Tekrar kontrol edermisiniz.

 

[Halit TÜRK]

Selamlar,

Mükemmel çalışıyor... 9. mesajdaki gibi [B2] hücresinden sayfa ismini aldırabilirmiyiz. Sadece bir sayfa kullanacağım. Sayfa Adı "FORM" sabit kalıyor.
B2 ye göre yedekliyor şeklinde düzenlenebilirmi.?

 

[Korhan Ayhan]

Selamlar,

Aşağıdaki kodu denermisiniz.

Sub YEDEK_AL()
    On Error Resume Next
    Dim Fso As Object
    Dim Dosya_Yolu As String, Dosya_Adı As String, Sayfa_Adı As String
    Dim X As Long, Ek As Integer
    Dosya_Yolu = "C:\YEDEK"
    Sayfa_Adı = "FORM"
    Ek = 1
    Set Fso = CreateObject("Scripting.FileSystemObject")
    
    If Not Fso.FolderExists(Dosya_Yolu) Then
    Fso.CreateFolder (Dosya_Yolu)
    End If
    
    Application.ScreenUpdating = False
    If [B2] <> "" Then
    Dosya_Ad&#305; = [B2]
    If SAYFA(Sayfa_Ad&#305;) Then
    Sheets(Sayfa_Ad&#305;).Copy
    
    If Dir(Dosya_Yolu & Application.PathSeparator & Dosya_Ad&#305; & ".xls", vbNormal) = "" Then
    ActiveWorkbook.SaveCopyAs Filename:=Dosya_Yolu & Application.PathSeparator & Dosya_Ad&#305; & ".xls"
    ActiveWorkbook.Close 0
    GoTo Son
    End If
Devam:
    If Dir(Dosya_Yolu & Application.PathSeparator & Dosya_Ad&#305; & " " & Ek & ".xls", vbNormal) = "" Then
    ActiveWorkbook.SaveCopyAs Filename:=Dosya_Yolu & Application.PathSeparator & Dosya_Ad&#305; & " " & Ek & ".xls"
    ActiveWorkbook.Close 0
    Else
    Ek = Ek + 1
    GoTo Devam
    End If
    End If
Son:
    Sheets(1).Select
    Application.ScreenUpdating = True
    Set Fso = Nothing
    MsgBox "Yedekleme i&#351;lemi tamamlanm&#305;&#351;t&#305;r.", vbInformation
    Else
    [B2].Select
    MsgBox "Yedekleme i&#351;lemi i&#231;in B2 h&#252;cresine dosya ad&#305; girmelisiniz !", vbCritical, "Dikkat !"
    End If
End Sub

 
Function SAYFA(SAYFAADI As String) As Boolean
    On Error Resume Next
    SAYFA = CBool(Len(Worksheets(SAYFAADI).Name) > 0)
End Function

 

[Halit TÜRK]

Selamlar,

Mükemmel çalışıyor.
Çok çok teşekkürler... Allah dert göstermesin...
Parantez içine almasını da halletmiş olduk.

Devam:
    If Dir(Dosya_Yolu & Application.PathSeparator & Dosya_Adı & " " & "(" & Ek & ")" & ".xls", vbNormal) = "" Then
    ActiveWorkbook.SaveCopyAs Filename:=Dosya_Yolu & Application.PathSeparator & Dosya_Adı & " " & "(" & Ek & ")" & ".xls"
    ActiveWorkbook.Close 0

İyi ki varsınız..