farklı kaydet butonu

[drykcktl]

merhaba arkadaşlar.bir konuda yardımızı rica ediyorum.yapmak istediğim
şudur.bu sayfada bir kaydet butonu oluşturmak istiyorum.ama kaydet dediğimde
ilgili ismi ve tarihle birlikte masa üstünde bulunan teklif dosyasına farklı kaydetsin
sayfayı.bununla beraber teklif klasöründe 1 excel sayfasınada dosya ismiyle köprü oluştursun ve tutarı yazsın.yapma şansımız varmı bilmiyorum ama yardomcı olusanız çok sevinirim.

http://dosya.co/fis9b733evy9/teklif_formu.rar.html

 

[askm]

Aşağıdaki kodlar işinize yarar sanırım.

Sub ASKM_AKTİF_DOSYAYI_YEDEKLE()
Dim DosyaSistemi
Set DosyaSistemi = CreateObject("Scripting.FileSystemObject")
Dim Yedek_Dosya_Adı As String, Kayıt_Yeri As String
yer = Environ("USERPROFILE") & "\Desktop\teklif\"
For i = 1 To Len(ThisWorkbook.Name)
If Mid(ThisWorkbook.Name, i, 1) = "." Then
Dosya = Mid(ThisWorkbook.Name, 1, i - 1)
uzanti = Mid(ThisWorkbook.Name, i, Len(ThisWorkbook.Name))
End If
Next

ActiveWorkbook.Save
Application.DisplayAlerts = False
Yedek_Dosya_Adı = Dosya & Format(Now, " dd_mm_yyyy_hh_mm") & uzanti
Kayıt_Yeri = yer & Yedek_Dosya_Adı
On Error Resume Next
If Dir(yer) = "" Then MkDir yer
On Error Resume Next
DosyaSistemi.CopyFile ThisWorkbook.FullName, Kayıt_Yeri
Cells(20, "C") = Kayıt_Yeri
ActiveSheet.Hyperlinks.Add Anchor:=Cells(20, "C"), Address:=Kayıt_Yeri, _
        TextToDisplay:=Kayıt_Yeri
MsgBox "Dosyanız aşağıdaki isimle yedeklenmiştir." & Chr(10) & Kayıt_Yeri, vbInformation, "ASKM"
Application.DisplayAlerts = True
End Sub

 

[drykcktl]

Aşağıdaki kodlar işinize yarar sanırım.

Sub ASKM_AKTİF_DOSYAYI_YEDEKLE()
Dim DosyaSistemi
Set DosyaSistemi = CreateObject("Scripting.FileSystemObject")
Dim Yedek_Dosya_Adı As String, Kayıt_Yeri As String
yer = Environ("USERPROFILE") & "\Desktop\teklif\"
For i = 1 To Len(ThisWorkbook.Name)
If Mid(ThisWorkbook.Name, i, 1) = "." Then
Dosya = Mid(ThisWorkbook.Name, 1, i - 1)
uzanti = Mid(ThisWorkbook.Name, i, Len(ThisWorkbook.Name))
End If
Next

ActiveWorkbook.Save
Application.DisplayAlerts = False
Yedek_Dosya_Adı = Dosya & Format(Now, " dd_mm_yyyy_hh_mm") & uzanti
Kayıt_Yeri = yer & Yedek_Dosya_Adı
On Error Resume Next
If Dir(yer) = "" Then MkDir yer
On Error Resume Next
DosyaSistemi.CopyFile ThisWorkbook.FullName, Kayıt_Yeri
Cells(20, "C") = Kayıt_Yeri
ActiveSheet.Hyperlinks.Add Anchor:=Cells(20, "C"), Address:=Kayıt_Yeri, _
        TextToDisplay:=Kayıt_Yeri
MsgBox "Dosyanız aşağıdaki isimle yedeklenmiştir." & Chr(10) & Kayıt_Yeri, vbInformation, "ASKM"
Application.DisplayAlerts = True
End Sub

denedim ama sanırım butona ekleyemedim sayın askm

 

[askm]

http://dosya.co/tkgj95n8xi37/MASAÜSTÜNE_FARKLI_KAYDET_VE_KÖPRÜ_OLUŞTUR.xlsm.html

 

[drykcktl]

merhabalar öncelikle yardımınız için teşekkür ederim.ama sanırım ben uygulama konusunda başarılı olamıyorum yolladığınız sayfada sadece bir köprü var ve belirtilen dosya açılamadı diyor.

 

[askm]

Masaüstü windows versiyonuna veya ağda kullanıma göre sanırım farklılık gösteriyor. Aşağıdaki şekilde denerseniz olur sanırım.

Sub ASKM_AKTİF_DOSYAYI_YEDEKLE()
Dim DosyaSistemi
Set DosyaSistemi = CreateObject("Scripting.FileSystemObject")
Dim Yedek_Dosya_Adı As String, Kayıt_Yeri As String
yer = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\" 'Application.PathSeparator
'Environ ("USERPROFILE") & "\Desktop\teklif\"
For i = 1 To Len(ThisWorkbook.Name)
If Mid(ThisWorkbook.Name, i, 1) = "." Then
Dosya = Mid(ThisWorkbook.Name, 1, i - 1)
uzanti = Mid(ThisWorkbook.Name, i, Len(ThisWorkbook.Name))
End If
Next

ActiveWorkbook.Save
Application.DisplayAlerts = False
Yedek_Dosya_Adı = Dosya & Format(Now, " dd_mm_yyyy_hh_mm") & uzanti
Kayıt_Yeri = yer & Yedek_Dosya_Adı
On Error Resume Next
If Dir(yer) = "" Then MkDir yer
On Error Resume Next
DosyaSistemi.CopyFile ThisWorkbook.FullName, Kayıt_Yeri
Cells(20, "C") = Kayıt_Yeri
ActiveSheet.Hyperlinks.Add Anchor:=Cells(20, "C"), Address:=Kayıt_Yeri, _
        TextToDisplay:=Kayıt_Yeri
MsgBox "Dosyanız aşağıdaki isimle yedeklenmiştir." & Chr(10) & Kayıt_Yeri, vbInformation, "ASKM"
Application.DisplayAlerts = True
End Sub

 

[drykcktl]

olmuyor maalesef

 

[askm]

http://dosya.co/bbyrt7iztyht/Masaüstü.zip.html

 

[askm]

Yukardaki linkte gönderdiğim örnekde benim bilgisayarda masaüstüne kayıt yapıyor ve kayıt yaptığı excele köprü oluşturuyor. (Tarihli olan örnek makro ile yapılmış örnek)

 

[drykcktl]

Yukardaki linkte gönderdiğim örnekde benim bilgisayarda masaüstüne kayıt yapıyor ve kayıt yaptığı excele köprü oluşturuyor. (Tarihli olan örnek makro ile yapılmış örnek)

bende hata veriyor butonla yapamazmıyın peki bunu ve direk masaüstüne değilde belirli bir klasöre kayıt yapsa

 

[askm]

yer = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\"
kısmını eğer aynı klasöre istiyorsanız
yer=Thisworkbook.Path & "\"
Eğer belirttiğiniz yere istiyorsanız;
yer= "D:\aaaa\" şeklinde yolunu yazarak deneyin.