İstediğim dosya adıyla farklı kaydet

[EmrExcel16]

Merhabalar ekteki tablo adındaki dosyamın içinde kaydet butonuna bastıgımda B sutunundaki malzemelerin Özetini E sutununa taşıyorum buraya kadar yaptım.

Burdan sonra tıkandım yardımlarınızı rica ederim.

Kaydet butonu özeti çıkardıktan sonra bana bir msj ekranı çıkartabilirmi eger çıkartırsa ben buraya dosya adını yazıcam tamam dediğimde bu dosyayı masaüstündeki Tablolar klasörüne farklı kaydedicek dosyalar masaüstünde.
Kaydederken benim vermiş olduğum ismin başına o günün tarihinide eklerse süper olur örneğin 2013.08.28 -145328 gibi

Kaydetme işlemi bittikten sonra Toblo isimli dosyada kalmam gerekir. Ve B5:C ,E5:F sutunlarının silinmesi lazımki işlemime tekrar devam edebileyim
Bu işlemi günde enaz 50 kere felan yapıcam konu benim için çok önemli lütfen yardımlarını rica ederim

 

[halit3]

Merhabalar ekteki tablo adındaki dosyamın içinde kaydet butonuna bastıgımda B sutunundaki malzemelerin Özetini E sutununa taşıyorum buraya kadar yaptım.

Burdan sonra tıkandım yardımlarınızı rica ederim.

Kaydet butonu özeti çıkardıktan sonra bana bir msj ekranı çıkartabilirmi eger çıkartırsa ben buraya dosya adını yazıcam tamam dediğimde bu dosyayı masaüstündeki Tablolar klasörüne farklı kaydedicek dosyalar masaüstünde.
Kaydederken benim vermiş olduğum ismin başına o günün tarihinide eklerse süper olur örneğin 2013.08.28 -145328 gibi

Kaydetme işlemi bittikten sonra Toblo isimli dosyada kalmam gerekir. Ve B5:C ,E5:F sutunlarının silinmesi lazımki işlemime tekrar devam edebileyim
Bu işlemi günde enaz 50 kere felan yapıcam konu benim için çok önemli lütfen yardımlarını rica ederim

kod:

Sub AKTİF_DOSYAYI_YEDEKLE()
Dim Yedek_Dosya_Adı As String, Kayıt_Yeri As String
Dim Klasor As String, uzanti As String, dosya As String
Dim masaustu As String, dosya_adı As String, yer As String

masaustu = CreateObject("wscript.Shell").SpecialFolders.Item("Desktop")
Klasor = "Tablolar"
dosya = ActiveWorkbook.Name
Set fLk = CreateObject("Scripting.FileSystemObject")
uzanti = fLk.GetExtensionName(dosya) ' uzantı buluyor
dosya_adı = fLk.GetBaseName(dosya)  ' klasörün kendisi

yer = InputBox("Dosyanın adını yazınız.", "Dosya Adı", "")

If yer = "" Then
MsgBox "İşlemi iptal ettiniz"
Exit Sub
End If


ActiveWorkbook.Save
Application.DisplayAlerts = False
Yedek_Dosya_Adı = Format(Now, " dd_mm_yyyy_") & yer & "." & uzanti
Kayıt_Yeri = masaustu & "\" & Klasor & "\" & Yedek_Dosya_Adı
If fLk.FolderExists(masaustu & "\" & Klasor) = False Then
MsgBox Klasor & " Klasoru yok şimdi oluşrurulacak"
MkDir masaustu & "\" & 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 "
Application.DisplayAlerts = True
 Range("B5:C5000").ClearContents
 Range("E5:F5000").ClearContents
End Sub

 

[Ömer]

Merhaba,

Alternatif olsun.
Eski kaydet kodlarını silip bu şekilde deneyin. İlaveyi kırmızı ile işaretledim.

Sub Kaydet()
Dim z As Object, i As Long, liste(), myarr(), sat As Long
Dim deg As String, sat2 As Long
Application.ScreenUpdating = False
Range("E5:F204").ClearContents
sat = Cells(Rows.Count, "B").End(xlUp).Row
liste = Range("B5:B" & sat).Value
Set z = CreateObject("Scripting.dictionary")
ReDim myarr(1 To 2, 1 To sat)
sat = UBound(liste)
For i = 1 To sat
    deg = liste(i, 1)
    If Not z.exists(deg) Then
        n = n + 1
        z.Add deg, n
        myarr(1, n) = liste(i, 1)
      End If
    myarr(2, z.Item(deg)) = myarr(2, z.Item(deg)) + 1
Next i
Erase liste: Set z = Nothing
ReDim Preserve myarr(1 To 2, 1 To n)
If n > 0 Then Range("E5").Resize(n, 2) = Application.Transpose(myarr)
[COLOR=red]Dim sor As String, dosya As String[/COLOR]
[COLOR=red]On Error Resume Next[/COLOR]
[COLOR=red]sor = InputBox("Dosya Adı Girin")[/COLOR]
[COLOR=red]If sor = "" Then Exit Sub[/COLOR]
[COLOR=red]dosya = CreateObject("Wscript.Shell").SpecialFolders.Item("Desktop") _[/COLOR]
[COLOR=red]  & "\Tablolar\" & Format(Now, "yyyy.mm.dd hhmmss") & " " & sor & ".xls"[/COLOR]
[COLOR=red]ActiveWorkbook.SaveCopyAs Filename:=dosya[/COLOR]
[COLOR=red]Range("B5:C204,E5:F204").ClearContents[/COLOR]
Application.ScreenUpdating = True
End Sub

 

[EmrExcel16]

Hocam teşekkür ederim tamda istediğim gibi olmuş sağolun varolun.

 

[EmrExcel16]

Hocalarım her ikinizede teşekkür ederim her ikiside mükemmel şekilde çalışıyor.

Yanlız şöyle bir sorum var E ve F sutunlarına koruma koyduğum zaman makro çalışmıyor çalışması için kodun başına korumayı kaldır sonunada sayfayı koru kodlarını ekliyorum bunun başka bir yolu varmıdır yoksa benim yaptığımdada sıkıntı olmaz mı. Sayfada korumasız kalıcak tek yer A5:B204 diğer yerler korumalı olucak .
Bir diğer sıkıntım ise farklı kaydettiği zaman makroların gitmemesi gibi bir durum olabilir mi acaba yani yeni dosyada makrolar vs olmasın sade bir dosya olması çok daha iyi olacak.
İyi çalışmalar..

 

[halit3]

Hocam teşekkür ederim tamda istediğim gibi olmuş sağolun varolun.

Hocalarım her ikinizede teşekkür ederim her ikiside mükemmel şekilde çalışıyor.

Yanlız şöyle bir sorum var E ve F sutunlarına koruma koyduğum zaman makro çalışmıyor çalışması için kodun başına korumayı kaldır sonunada sayfayı koru kodlarını ekliyorum bunun başka bir yolu varmıdır yoksa benim yaptığımdada sıkıntı olmaz mı. Sayfada korumasız kalıcak tek yer A5:B204 diğer yerler korumalı olucak .
Bir diğer sıkıntım ise farklı kaydettiği zaman makroların gitmemesi gibi bir durum olabilir mi acaba yani yeni dosyada makrolar vs olmasın sade bir dosya olması çok daha iyi olacak.
İyi çalışmalar..

Dört ve beşinci mesajlarınızı alıntı yaptım yukarıda

Sorunuza iki kişi cevap vermiş dördüncü mesajınızda kodun olduğunu belirtmişsiniz. Hangi kod işinizi gördü bende merak ettim.

Beşinci mesajınızda size cevap veren iki kişeye sorunuzu farklı bir şekilde yeniden yönlerdirmişsiniz.

Aslında sorunuza ta ilk başta cevap versemmi diye teredüte düşmüştüm.

Çünkü sorunuzda farklı kayıt etme ile ilgili fazla detay yoktu.

Beş nolu sorunuzla ilgili farklı kayıt işleminin kodları tamamen değişmektedir.

kod:

Sub YEDEKLE()
Dim Yedek_Dosya_Adı As String, Kayıt_Yeri As String
Dim Klasor As String, Uzanti As String, Dosya As String
Dim masaustu As String, dosya_adı As String, yer As String

masaustu = CreateObject("wscript.Shell").SpecialFolders.Item("Desktop")
Klasor = "Tablolar"
Dosya = ActiveWorkbook.Name
Set fLk = CreateObject("Scripting.FileSystemObject")
Uzanti = fLk.GetExtensionName(Dosya)
dosya_adı = fLk.GetBaseName(Dosya)

yer = InputBox("Dosyanın adını yazınız.", "Dosya Adı", "")

If yer = "" Then
MsgBox "İşlemi iptal ettiniz"
Exit Sub
End If

Worksheets(ActiveSheet.Name).Protect Password:="10", Contents:=False, Scenarios:=False

ActiveSheet.Copy

For Each ModX In ActiveWorkbook.VBProject.VBComponents
Set VBCodeMod = ActiveWorkbook.VBProject.VBComponents(ModX.Name).CodeModule
VBCodeMod.DeleteLines 1, VBCodeMod.CountOfLines
Next

ActiveSheet.DrawingObjects.Delete

Application.DisplayAlerts = False
Yedek_Dosya_Adı = Format(Now, " dd_mm_yyyy_") & yer & "." & Uzanti
Kayıt_Yeri = masaustu & "\" & Klasor & "\" & Yedek_Dosya_Adı

If fLk.FolderExists(masaustu & "\" & Klasor) = False Then
MsgBox Klasor & " Klasoru yok şimdi oluşrurulacak"
MkDir masaustu & "\" & Klasor
End If

If Val(Application.Version) >= 12 Then
ActiveWorkbook.SaveAs Kayıt_Yeri  ', FileFormat:=xlExce12
Else
ActiveWorkbook.SaveAs Kayıt_Yeri, FileFormat:=xlNormal  '56 ' xlExcel9795
End If
ActiveWorkbook.Close False

MsgBox "Dosyanız aşağıdaki isimle yedeklenmiştir." & Chr(10) & Chr(10) & Kayıt_Yeri, vbInformation, "U Y A R I "
Application.DisplayAlerts = True
Range("B5:C5000").ClearContents
Range("E5:F5000").ClearContents
Worksheets(ActiveSheet.Name).Protect Password:="10", Contents:=True, Scenarios:=True

End Sub

 

[EmrExcel16]

Kusura bakmayın bunu belirtmek aklıma gelmemişti haklısınız ikinizinkide farklı şekilde siz sorumu yanlış anladığınız için size son olarak anlattıklarım karışık gelmiş olabilir Ömer hocam beni anlamış ve benim anlattıklarımı olduğu gibi uygulamış sizin vermiş olduğunuz kod da yanlış değil ama sizin kodunuzla benim kodumu birleştirdim ama Ömer hocam bunları birleştirip ilk mesajımda yazdığım gibi yapmış.
Ben konuya tekrar sorumu Ömer hocamın cevabına istinaden vermiştim ama dediğim gibi kime cevap verdiğimi ve bunu belirtmem gerektiği aklıma gelmedi vermiş olduğum rahatsızlık için özür diliyorum lütfen kusurumu maruz görün.