Farklı Kaydet

[ormann]

İyi günler;
Ekteki örnek dosyadaki farklı kaydet butonuna bastığımda ekrana kutucuk gelip,kutucuğun içerisine dosya adı olarak sadece numa
girip ,kaydet butonuna bastığımızda ise d klasörünün içerisinde satış klasörünün içerisine İSTİF NO=5 diye kayıt yaptırabilirmiyiz?.Ayrıca kayıt edilecek klasörün içerisinde aynı isimli dosya varsa "farklı numara veriniz diye bir uyarı yazısı gelebilir mi?Yardımcı olabilirmisiniz?

 

[ormann]

Arkadaşlar makro ile böyle bir şey yapılabilir mi?

 

[halit3]

İyi günler;
Ekteki örnek dosyadaki farklı kaydet butonuna bastığımda ekrana kutucuk gelip,kutucuğun içerisine dosya adı olarak sadece numa
girip ,kaydet butonuna bastığımızda ise d klasörünün içerisinde satış klasörünün içerisine İSTİF NO=5 diye kayıt yaptırabilirmiyiz?.Ayrıca kayıt edilecek klasörün içerisinde aynı isimli dosya varsa "farklı numara veriniz diye bir uyarı yazısı gelebilir mi?Yardımcı olabilirmisiniz?

Sitede bunanla ilgili bir sürü örnek kod mevcut

Alternatif olması için kod:

Sub AKTİF_DOSYAYI_YEDEKLE()
Application.ScreenUpdating = False
Application.EnableEvents = False
dosya = ActiveWorkbook.Name
Set flk = CreateObject("Scripting.FileSystemObject")
uzanti = flk.GetExtensionName(dosya) ' uzantı buluyor
dosya2 = flk.GetBaseName(dosya) ' dosyanın kendisi
Klasor = "D:\satış"
Dosya_adi = InputBox("dosyanın adını değiştirebilirsiniz.", "UYARI!", dosya2)
If Dosya_adi = "" Then MsgBox "dosya adını yazmadınız.": Exit Sub
Kayıt_Yeri = Klasor & "\" & Dosya_adi & "." & uzanti
If CreateObject("Scripting.FileSystemObject").FileExists(Kayıt_Yeri) = True Then
MsgBox " Bu isimde bir dosya var"
Else
ActiveWorkbook.Save
If flk.FolderExists(Klasor) = False Then
MkDir Klasor
End If
flk.CopyFile ThisWorkbook.FullName, Kayıt_Yeri
MsgBox "Dosyanız aşağıdaki isimle yedeklenmiştir." & Chr(10) & Chr(10) & Kayıt_Yeri, vbInformation, "U Y A R I "
End If
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub

 

[ormann]

Sayın Halit bey çok teşekkür ederim.Tam istediğim gibi çalışıyor.Örneğin dosya adını 5 girdiğimde satış klasörüne kayıt yaparken İSTİF NO=5 olarak kayıt yaptırabilirmiyiz.?.Birde Yedekleme yaparken hücre aaralığı olarak a1:y72 olarak yedekleyebilirmiyiz?

 

[halit3]

Sayın Halit bey çok teşekkür ederim.Tam istediğim gibi çalışıyor.Örneğin dosya adını 5 girdiğimde satış klasörüne kayıt yaparken İSTİF NO=5 olarak kayıt yaptırabilirmiyiz.?.Birde Yedekleme yaparken hücre aaralığı olarak a1:y72 olarak yedekleyebilirmiyiz?

Bu yazdıklarınızı önceden söyleseniz olmuyormu kodların hepsini yeniden revize ettik yani sil baştan yeniden yazdık.

kod:

Sub AKTİF_DOSYAYI_YEDEKLE2()
yer = InputBox("dosyanın adını değiştirebilirsiniz.", "UYARI!", "")
If yer = "" Then MsgBox "dosya adını yazmadınız.": Exit Sub
Application.ScreenUpdating = False
Application.EnableEvents = False
Dim FileFormatNum As Long
Klasor = "D:\satış"
Dosya_adi = ActiveWorkbook.Name
Sayfa_Adı = ActiveSheet.Name
Set fLk = CreateObject("Scripting.FileSystemObject")
uzanti = fLk.GetExtensionName(Dosya_adi) ' uzantı buluyor
dosya = fLk.GetBaseName(Dosya_adi) ' dosyanın kendisi
 
If uzanti = "xls" Then
FileFormatNum = -4143
ElseIf uzanti = "xlsx" Then
FileFormatNum = 51
ElseIf uzanti = "xlsm" Then
FileFormatNum = 52
ElseIf uzanti = "xlsb" Then
FileFormatNum = 50
ElseIf uzanti = "xls" Then
FileFormatNum = 56
End If
 
ThisWorkbook.Sheets(Sayfa_Adı).Range("A1:Y72").Copy
Dim oBook As Object
Dim oSheet3 As Object
Dim oSheet2 As Object
Set oBook = Workbooks.Add
Set oSheet3 = oBook.Worksheets(3)
Set oSheet2 = oBook.Worksheets(2)
Range("A1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Range("A1").Select
Application.DisplayAlerts = False
oSheet3.Delete
oSheet2.Delete
Application.DisplayAlerts = True
Application.CutCopyMode = False
Kayıt_Yeri = Klasor & "\İSTİF NO " & yer & "." & uzanti
If CreateObject("Scripting.FileSystemObject").FileExists(Kayıt_Yeri) = True Then
MsgBox " Bu isimde bir dosya var"
Application.DisplayAlerts = False
ActiveWindow.Close
Else
ActiveWorkbook.SaveAs Kayıt_Yeri, FileFormat:=FileFormatNum
ActiveWorkbook.Close SaveChanges:=False
MsgBox yer & " Dosya kayıt edildi"
End If
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub

 

[ormann]

Sayın Halit hocam çok teşekkür ederim.Ellerinize sağlık