Herkese Merhabalar, iyi çalışmalar dilerim. Önceki açtığım konuda çözüme ulaşamadığım için yeni bir konuda daha işime yarıcak bir makro konusunda yardımınızı rica ediyorum. Aşağıya örnek dosyayı ekledim. Yapmak istediğim tam olarak şöyle ; deneme adlı dosyamda yeni kayıt makrosu var. Bu makroyla yeni girdiğim verilerimi kaydediyorum. Makroyu çalıştırdığımız zaman ANA SAYFA yı kopyalıyor kayıtlar klösörü açıp burda yeni bir dosya oluşturuyor. Bu dosyanın ismine de ANA SAYFA V1 hücresindeki tarihi atıyor sonrada ANA SAYFA yı bu yeni oluşturduğu dosyaya kopyalayıp çıkıyor. Fakat aynı isimdeki dosyaya yeni veri eklemek istdeğim zaman kaydet deyince bu dosyadan zaten var diye uyarıyor, yapmak istediğim aynı isim deki dosyaya yeni veriler eklemek. Fakat yeni kayıt komple ana sayfayı kopyalayıp eklemesin A4 ve U4 aralığı dahil olmak üzere aşağı doğru kaydetmek istediğim verileri yeni dosyadaki A4 ve U4 satırından aşağı doğru ilk boş olan satıra eklesin istiyorum. ilgilenirseniz çok sevinirim.
Dosya : http://s4.dosya.tc/server6/6bavpe/deneme.rar.html
Buda makro :
Sub Yeni_kayıt()
Set s1 = Sheets("ANA SAYFA")
ad = s1.Cells(1, "V").Value
If ad = "" Then MsgBox "Lütfen Tarih Giriniz": Exit Sub
Set ds = CreateObject("Scripting.FileSystemObject")
yol = ThisWorkbook.Path & "\"
If ds.FolderExists(yol & "Kayıtlar") = False Then ds.CreateFolder yol & "Kayıtlar"
If ds.FileExists(ThisWorkbook.Path & "\Kayıtlar\" & ad & ".xlsx") = True Then MsgBox ad & " Dosyası zaten var": Exit Sub
Application.ScreenUpdating = False
s1.Visible = True
ChDir ThisWorkbook.Path & "\Kayıtlar\"
kayıt = CreateObject("wscript.Shell").SpecialFolders.Item(ThisWorkbook.Path & "\Kayıtlar\") & _
ad & ".xlsx": s1.Copy
ActiveWorkbook.Sheets(Sheets.Count).Name = "Data"
ActiveWorkbook.SaveAs Filename:=kayıt
ActiveWorkbook.Close
Application.ScreenUpdating = True
ThisWorkbook.Save
MsgBox ad & " Dosyası Kayıtlar klasörüne kaydedildi"
End Sub
Dosya : http://s4.dosya.tc/server6/6bavpe/deneme.rar.html
Buda makro :
Sub Yeni_kayıt()
Set s1 = Sheets("ANA SAYFA")
ad = s1.Cells(1, "V").Value
If ad = "" Then MsgBox "Lütfen Tarih Giriniz": Exit Sub
Set ds = CreateObject("Scripting.FileSystemObject")
yol = ThisWorkbook.Path & "\"
If ds.FolderExists(yol & "Kayıtlar") = False Then ds.CreateFolder yol & "Kayıtlar"
If ds.FileExists(ThisWorkbook.Path & "\Kayıtlar\" & ad & ".xlsx") = True Then MsgBox ad & " Dosyası zaten var": Exit Sub
Application.ScreenUpdating = False
s1.Visible = True
ChDir ThisWorkbook.Path & "\Kayıtlar\"
kayıt = CreateObject("wscript.Shell").SpecialFolders.Item(ThisWorkbook.Path & "\Kayıtlar\") & _
ad & ".xlsx": s1.Copy
ActiveWorkbook.Sheets(Sheets.Count).Name = "Data"
ActiveWorkbook.SaveAs Filename:=kayıt
ActiveWorkbook.Close
Application.ScreenUpdating = True
ThisWorkbook.Save
MsgBox ad & " Dosyası Kayıtlar klasörüne kaydedildi"
End Sub