Farkli kaydet ile değişik klasölere kaydetme için makro rica

[Zeyback]

Merhabalar,

Benim masa üstünde 3 ayrı klasöre var BUnlar A,B,C şeklinde

1. bunları macrosuz (xlsx) formatında
2. bu dosyaları h10 hücresindeki bilgiye göre
örnek A yazıyorsa Masa üstündeki A klasörüne, B yazıyorsa masaüstündeki B klasörüne tarih ve saat ekleyerek kaydetsin (makrosuz)..

yardımlarınız için şimdiden teşekkürler

 

[askm]

Private Sub CommandButton1_Click()
Set klasor = CreateObject("WScript.Shell")
adrs = klasor.SpecialFolders("Desktop")
isim = ThisWorkbook.Name
isim = Mid(isim, 1, Len(isim) - 5)
Klasör = [H10]
MkDir (adrs & "\" & Klasör)
ThisWorkbook.SaveAs Filename:=adrs & "\" & Klasör & "\" & isim
End Sub

 

[askm]

Pardon aşağıdaki şekilde olması gerekli.

Private Sub CommandButton1_Click()
On Error Resume Next
Set klasor = CreateObject("WScript.Shell")
adrs = klasor.SpecialFolders("Desktop")
isim = ThisWorkbook.Name
isim = Mid(isim, 1, Len(isim) - 5)
Klasör = [H10]
MkDir (adrs & "\" & Klasör)
ThisWorkbook.SaveCopyAs Filename:=adrs & "\" & Klasör & "\" & isim & ".xlsx"
End Sub

 

[Zeyback]

merhaba, askm

dosyayı xlxs extension olarak kaydediyor fakat dosyanın sadece extension kısmı değişmiş oluyor yani açılmıyor (formatı değişmiyor) extension nu tekrar xlsm yapınca açıyor
son bir ricam olacak a2 hücresindeki ismi aynı zamanda dosya ismi olarak kaydedebilir mi?

 

[askm]

Private Sub CommandButton1_Click()
On Error Resume Next
Set klasor = CreateObject("WScript.Shell")
adrs = klasor.SpecialFolders("Desktop")
isim = ThisWorkbook.Name
isim = [A2]
Klasör = [H10]
MkDir (adrs & "\" & Klasör)
ThisWorkbook.SaveCopyAs Filename:=adrs & "\" & Klasör & "\" & isim & ".xlsx"
End Sub

 

[Zeyback]

merhaba, askm

dosyayı xlxs extension olarak kaydediyor fakat dosyanın sadece extension kısmı değişmiş oluyor yani açılmıyor (formatı değişmiyor) extension nu tekrar xlsm yapınca açıyor

 

[askm]

Sub ASKM_Makrosuz_Kayıt()
On Error Resume Next
Set klasor = CreateObject("WScript.Shell")
Klasör = [H10]
adrs = klasor.SpecialFolders("Desktop")
MkDir (adrs & "\" & Klasör)
isim = adrs & "\" & Klasör & "\" & [A2] & ".xlsx"


    With ThisWorkbook
        .Sheets.Copy
        ActiveWorkbook.SaveAs _
            Filename:=isim, FileFormat:=xlOpenXMLWorkbook
    End With
    ActiveWorkbook.Close False 'xlsx doyayı kapatmak için
MsgBox "xlsx olarak Yedek Alındı...", vbInformation, "ASKM"
End Sub

 

[halit3]

Alternatif kod

Sub kaydet()

With Application
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
End With



Dim Klasor As String
Dim Sayfa_Adı As String
Sayfa_Adı = ActiveSheet.Name


Dim fL As Object
Set fL = CreateObject("Scripting.FileSystemObject")

Klasor = CreateObject("wscript.Shell").SpecialFolders("Desktop") & "\" & Cells(10, "h")
If fL.FolderExists(Klasor) = False Then
MkDir Klasor
End If

ThisWorkbook.Worksheets.Copy

For i = 1 To ActiveWorkbook.Sheets.Count
Sheets(Sheets(i).Name).DrawingObjects.Delete
Next

ActiveWorkbook.SaveAs Klasor & "\" & Format(Now, "yyyy_mm_dd   hh_nn_ss") & ".xlsx", FileFormat:=51
ActiveWorkbook.Close False
MsgBox "işlem tamam", vbInformation, "U Y A R I"
With Application
.ScreenUpdating = True
.EnableEvents = True
.DisplayAlerts = True
End With

Sheets(Sayfa_Adı).Select

End Sub

 

[Zeyback]

Askm ve Halit


yardımlarınızdan dolayı çok teşekkürler.