Bulunduğumuz ayı isim bilerek masaüstüne kaydetme

[Tornael]

Selamlar,

Çalışmakta olduğumuz exceli masaüstüne bu ayı ve yanınada 3.dosya yazarak kaydetme imkanızımız varmıdır ?

Örn. Masaüstü => "Nisan 3. dosya" gibi

Yardımlarınız için şimdiden teşekkür ederim.

 

[halit3]

kod:

Sub kaydet()
Dim Kayıt_Yeri As String
Dim flk, uzanti, dosya
dosya = ThisWorkbook.FullName
Set flk = CreateObject("Scripting.FileSystemObject")
uzanti = flk.GetExtensionName(dosya)  ' uzantı buluyor
ThisWorkbook.Save
Application.DisplayAlerts = False
Kayıt_Yeri = CreateObject("wscript.Shell").SpecialFolders("Desktop") & "\" & Format(Now, " mmmm mm")
flk.CopyFile dosya, Kayıt_Yeri & "." & uzanti
MsgBox "Dosyanız aşağıdaki isimle kayıt edilmiştir." & Chr(10) & Kayıt_Yeri, vbInformation, "U Y A R I"
Application.DisplayAlerts = True
End Sub

 

[Tornael]

Teşekkürler.

Halt Bey,

Kodlar gereğinden fazlasını bile yapıyor oldukça iyi.
Bir ilave daha istesem, yalnızca bulunduğu çalışma sayfasını kaydedebilir miyiz...

 

[halit3]

Arama yaparsanız bu ve benzer konularda bir sürü örnek bulabilirsiniz.

kod:

Sub kaydet()
Dim Kayıt_Yeri As String
Dim flk, uzanti, dosya
dosya = ThisWorkbook.FullName
Set flk = CreateObject("Scripting.FileSystemObject")
uzanti = flk.GetExtensionName(dosya)  ' uzantı buluyor
Application.DisplayAlerts = False
Kayıt_Yeri = CreateObject("wscript.Shell").SpecialFolders("Desktop") & "\" & Format(Now, " mmmm mm")
ActiveSheet.Copy
yer = MsgBox("Sayfada eğer makro varsa silmek istiyormusunuz.?", vbYesNo + vbInformation, " Makro silme penceresi")
If yer = vbYes Then
ActiveSheet.DrawingObjects.Delete
For Each component In ActiveWorkbook.VBProject.VBComponents
If component.Type <> 100 Then
ActiveWorkbook.VBProject.VBComponents.Remove component
Else
Set modul = component.CodeModule
modul.DeleteLines 1, modul.CountOfLines
End If
Next
End If

ActiveWorkbook.SaveAs Kayıt_Yeri & "." & uzanti
ActiveWorkbook.Close False
MsgBox "Dosyanız aşağıdaki isimle kayıt edilmiştir." & Chr(10) & Kayıt_Yeri, vbInformation, "U Y A R I"
Application.DisplayAlerts = True
End Sub

 

[Tornael]

Halit Bey,

Çok saolun bir istiyorum 2 de siz katıyorsunuz.
Bir sorun çıktı ekte resmi var.
Nasıl düzeltilebilir...

 

[halit3]

Halit Bey,

Çok saolun bir istiyorum 2 de siz katıyorsunuz.
Bir sorun çıktı ekte resmi var.
Nasıl düzeltilebilir...

kod:

Sub kaydet()
Dim Kayıt_Yeri As String
Dim flk, uzanti, dosya
dosya = ThisWorkbook.FullName
Set flk = CreateObject("Scripting.FileSystemObject")
uzanti = flk.GetExtensionName(dosya)  ' uzantı buluyor
Application.DisplayAlerts = False
Kayıt_Yeri = CreateObject("wscript.Shell").SpecialFolders("Desktop") & "\" & Format(Now, " mmmm mm")
ActiveSheet.Copy
yer = MsgBox("Sayfada eğer makro varsa silmek istiyormusunuz.?", vbYesNo + vbInformation, " Makro silme penceresi")
If yer = vbYes Then
ActiveSheet.DrawingObjects.Delete
For Each component In ActiveWorkbook.VBProject.VBComponents
If component.Type <> 100 Then
ActiveWorkbook.VBProject.VBComponents.Remove component
Else
Set modul = component.CodeModule
modul.DeleteLines 1, modul.CountOfLines
End If
Next
End If

If uzanti = "xls" Then
FileFormatNum = -4143
ElseIf uzanti = "xlsm" Then
FileFormatNum = 52
ElseIf uzanti = "xlsx" Then
FileFormatNum = 51
ElseIf uzanti = "xlsb" Then
FileFormatNum = 50
Else
FileFormatNum = 56
End If
ActiveWorkbook.SaveAs Kayıt_Yeri & "." & uzanti, FileFormat:=FileFormatNum  'Uzanti
ActiveWorkbook.Close False
MsgBox "Dosyanız aşağıdaki isimle kayıt edilmiştir." & Chr(10) & Kayıt_Yeri, vbInformation, "U Y A R I"
Application.DisplayAlerts = True
End Sub

 

[Tornael]

Tebrikler

Zihninize sağlık çok saolun Halit Bey...