Koşula göre uygun dosyaya veri kopyalama.!!!!

[sinan05]

Merhaba iyi çalışmalar değerli Hocalarım. 1 gündür uğraştığım sorunuma çözüm bulamıyorum. Yardımcı olursanız çok sevinirim. Aşağıya eklemiş olduğum makro çalışma kitamımdaki s2 (ÖRNEK TASLAK) sayfasını kopyalayıp, "ARAÇ KAYITLARI" Klasörüne yeni bir dosya açıp kodlara göre dosyaya isim verip, sonra burda yeni bir sayfa açıp yine kodlara göre sayfaya isim vererek kopyaladığı s2 sayfasını buraya yapıştırıyor en sonda da ilgili yere köprü atıyor. . Aynı ada sahip dosyadan varsa o dosyada yeni bir sayfa açıp oraya kaydediyor. Benim arzu ettiğim makro s2 sayfasını "ARAÇ KAYITLARI" klasöründe 5 sayfadan az olan dosyaya kaydetsin dosyalar 5 sayfayla sınırlı kalsın istiyorum. yani eğer "ARAÇ KAYITLARI" Klasöründe ki dosyalardan birinde 3 sayfa varsa bu dosyaya kaydetsin eğer dosya 5 sayfaysa yeni bir dosya açıp oraya kaydetsin bu şekilde her dosyaya 5 sayfaya kadar kaydedip döngü devam etsin. Aynı dosyaya kayıt yapacaksa dosya ismini değiştirmesine gerek yok .Şİmdiden teşekkür ederim.

Sub aracı_klosore_kaydet()
Application.ScreenUpdating = False
Set s1 = Sheets("ARAÇ KAYIT")
Set s2 = Sheets("ÖRNEK TASLAK")
Set s3 = Sheets("ARAÇ LİSTESİ")
ad = s1.Cells(1, "Q").Value
ad1 = s1.Cells(3, "B").Value
If ad = "" Then MsgBox "Müşteri adı-soyadı giriniz": Exit Sub
Set ds = CreateObject("Scripting.FileSystemObject")
yol = ThisWorkbook.Path & "\"
If ds.FolderExists(yol & "ARAÇ KAYITLARI") = False Then ds.CreateFolder yol & "ARAÇ KAYITLARI"
If ds.FileExists(ThisWorkbook.Path & "\ARAÇ KAYITLARI\" & ad & ".xlsx") = True Then
MsgBox ad & " Dosyası var sayfa eklenecek"
Workbooks.Open ThisWorkbook.Path & "\ARAÇ KAYITLARI\" & ad & ".xlsx"
s2.Visible = True
s2.Cells.Copy
With ActiveWorkbook
Sheets.Add After:=.Sheets(.Sheets.Count)
.Sheets(.Sheets.Count).Name = .Sheets.Count
.Sheets(.Sheets.Count).Paste
.Sheets(.Sheets.Count).Range("a1").Select
Application.CutCopyMode = False
.Close savechanges:=True
End With
Exit Sub
End If
s2.Visible = True
ChDir ThisWorkbook.Path & "\ARAÇ KAYITLARI\"
kayıt = CreateObject("wscript.Shell").SpecialFolders.Item(ThisWorkbook.Path & "\ARAÇ KAYITLARI\") & _
ad & ".xlsx": s2.Copy
ActiveWorkbook.Sheets(Sheets.Count).Name = s1.Cells(4, "B").Value & "_" & s1.Cells(5, "B").Value
ActiveWorkbook.SaveAs Filename:=kayıt
ActiveWorkbook.Close
s2.Visible = False
x = s3.Cells(Rows.Count, "A").End(3).Row + 1
s3.Cells(x, "A") = s1.[B2]
s3.Cells(x, "B") = s1.[B3]
s3.Cells(x, "C") = s1.[B4]
s3.Cells(x, "D") = s1.[B5]
s3.Hyperlinks.Add Anchor:=s3.Cells(x, "B"), Address:= _
"ARAÇ KAYITLARI\" & ad & ".xlsx", TextToDisplay:=s1.Cells(3, "B").Value
ThisWorkbook.Save
s2.Visible = False
Application.ScreenUpdating = True
End Sub

 

[sinan05]

Acaba yardım edebilecek müsait bir Hocamız yok mu Lütfen..

 

[sinan05]

Bununda uğraşarak çeşitli denemelerle çözümünü buldum. Artık istediğim sayfa sayısından sonra otomatik yeni dosya oluşturup oraya kaydettiriyorum. Yinde benzer sorunu olan çıkarsa yardımcı olmak isterim. İyi günler.