Butonla farklı kaydet tarih saat ekle

[S.Yiğit]

Merhabalar,

Farklı kaydet butonuna tıkladığımda aşağıda belirttiğim Dosya yoluna A1 hücresindeki ismi verecek ve yanına o günün tarih ve saatini atacak

Örnek 614 Pappalons Projesi 27.01.2011 12:35

dosya yolu: \\Podc\pol\teklifler\FAYDALI BILGILER\SERVİS\PB TEKLİF & KABUL\2011\SERVİS MALİYETLERİ HESAPLAMA

Sadece geçerli sayfayı kaydetmeli, katsayılar ve açılımlar sayfalarını almamalı ayrıca yeni kaydettiği dosyada makro olmamalı.

Yardım edenlere şimdiden teşekkür ederim..

 

[halit3]

Merhabalar,

Farklı kaydet butonuna tıkladığımda aşağıda belirttiğim Dosya yoluna A1 hücresindeki ismi verecek ve yanına o günün tarih ve saatini atacak

Örnek 614 Pappalons Projesi 27.01.2011 12:35

dosya yolu: \\Podc\pol\teklifler\FAYDALI BILGILER\SERVİS\PB TEKLİF & KABUL\2011\SERVİS MALİYETLERİ HESAPLAMA

Sadece geçerli sayfayı kaydetmeli, katsayılar ve açılımlar sayfalarını almamalı ayrıca yeni kaydettiği dosyada makro olmamalı.

Yardım edenlere şimdiden teşekkür ederim..

Bunu denermisiniz.

Sub aktar()
Application.ScreenUpdating = False
On Error Resume Next
Kaynak = "[URL="file://\\Podc\pol\teklifler\FAYDALI"]\\Podc\pol\teklifler\FAYDALI[/URL] BILGILER\SERVİS\PB TEKLİF & KABUL\2011\SERVİS MALİYETLERİ HESAPLAMA"
Dosya_adi = Sheets("Hesap").Cells(1, "a").Value
Tarih = Format(Now, "dd/mm/yyyy__hh/mm")
For i = Len(ThisWorkbook.Name) To 1 Step -1
If Mid(ThisWorkbook.Name, i, 1) = "." Then
'Dosya_adi = Mid(ThisWorkbook.Name, 1, i - 1)
Uzanti = Mid(ThisWorkbook.Name, i, Len(ThisWorkbook.Name))
Exit For
End If
Next
Sheets("Hesap").Range("A1:M43").Copy
Application.WindowState = xlMinimized
Workbooks.Add
ActiveSheet.Paste
Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Application.DisplayAlerts = False
For i = ActiveWorkbook.Sheets.Count To 2 Step -1
Sheets(Sheets(i).Name).Select
ActiveWindow.SelectedSheets.Delete
Next
ActiveSheet.DrawingObjects.Delete
Sheets(ActiveSheet.Name).Name = "Hesap"
deger = Dosya_adi & " " & Tarih & Uzanti
Range("a1").Select
'Worksheets(ActiveSheet.Name).Protect Password:="123", Contents:=True, Scenarios:=True
ActiveWorkbook.SaveAs Filename:=Kaynak & "\" & deger
ActiveWindow.Close
ActiveWindow.WindowState = xlMaximized
Application.VBE.MainWindow.Visible = False
Application.ScreenUpdating = True
MsgBox "işlem tamam"
End Sub

 

[S.Yiğit]

Sn. Halit hocam merhaba,

Kusura bakmayın geç cevap veriyorum.. Kod gayet güzel çalışıyor. Kodu çalıştırınca excel sayfası kayboluyor araç çubuğuna iniyor ve masa üstünü gösteriyor veya baska sayfa varsa onu gösteriyor ama bu haliylede işimi görür.. Teşekkürler, elinize sağlık..