Yeni Excel Calısma Kitabına Verileri Kaydetme Hk.

[Kemal Demir]

Arkadaslar Merhaba,
Başlık biraz karmasık oldu özür dilerim forumdaki arkadaşlarımdan.

Selam,
Kod ile Her durum olasılıklarını durum ismine göre sheet'lere atıyorum.
Yalnız bu işi Farklı Sheetler yerine her sheet için C:\sonuclar
Folder'ının içerisine ornek (1 durum) , (2 durum),... Her durum ıcın yenı bir xls dosyası altında nasıl atabiliriz.
Bu konuda yardımcı olabilirmisiniz.

Not:Yeni Açılacak olan xls dosya isimlerini göndermiş oldugum dosya içerisinde a6:bq6 değerleri içerisinden alacak


Dosya Ek'tedir. Kodu çalıştırdıgınızda Sorunumu daha iyi anlayacaksınız.

Teşekkur Ederim.

 

[Kemal Demir]

Bu konuda Yardımlarını bekliyorum arkadaslar.

 

[Kemal Demir]

Sub dagitt()
On Error Resume Next
MkDir "c:\xxx"
Application.DisplayAlerts = False 'dosyanın üzerine yazayımmı diye sormamasını direk üstüne kaydetmesini sağlar
For x = 2 To 69
Sheets.Add , after:=Sheets(Sheets.Count)
Range("a1:a25").Value = Sheets(1).Range("a1:a25").Value
Range("a1:a3").Font.Bold = True
Range("a1:a3").Font.ColorIndex = 2
Range("a1:a3").Interior.ColorIndex = 47
Range("a6:b6").Font.ColorIndex = 6
Range("a6:b6").Interior.ColorIndex = 3
Range("a6:b6").Font.Bold = True
Cells(6, 2).Value = Sheets(1).Cells(6, x).Value
Cells(7, 2).Value = Sheets(1).Cells(7, x).Value
Cells(8, 2).Value = Sheets(1).Cells(8, x).Value
Cells(9, 2).Value = Sheets(1).Cells(9, x).Value
Cells(10, 2).Value = Sheets(1).Cells(10, x).Value
Cells(11, 2).Value = Sheets(1).Cells(11, x).Value
Cells(12, 2).Value = Sheets(1).Cells(12, x).Value
Cells(13, 2).Value = Sheets(1).Cells(13, x).Value
Cells(14, 2).Value = Sheets(1).Cells(14, x).Value
Cells(15, 2).Value = Sheets(1).Cells(15, x).Value
Cells(16, 2).Value = Sheets(1).Cells(16, x).Value
Cells(17, 2).Value = Sheets(1).Cells(17, x).Value
Cells(18, 2).Value = Sheets(1).Cells(18, x).Value
Cells(19, 2).Value = Sheets(1).Cells(19, x).Value
Cells(20, 2).Value = Sheets(1).Cells(20, x).Value
Cells(21, 2).Value = Sheets(1).Cells(21, x).Value
Cells(22, 2).Value = Sheets(1).Cells(22, x).Value
Cells(23, 2).Value = Sheets(1).Cells(23, x).Value
Cells(24, 2).Value = Sheets(1).Cells(24, x).Value
ActiveSheet.Name = Left(Range("b6"), 30)
[a3].Value = [a3].Value& & " " & [b6].Value
ad = [b6]
Sheets(x).Copy ' sayfanın yeni bir workbook''a kopyasını alır
ActiveWorkbook.SaveAs Filename:="C:\xxx\" & ad

ActiveWorkbook.Save
ActiveWorkbook.Close
Cells.Select
Cells.EntireColumn.AutoFit
Range("a3").Font.ColorIndex = 2
Range("a3").Interior.ColorIndex = 3
Range("a22:B22").Font.Bold = True
Range("a22:B22").Font.ColorIndex = 2
Range("a22:B22").Interior.ColorIndex = 3

Next
End Sub


Altı çizili kısmı aramıstım.sonunda sonuca ulaştım.Sizlerle paylaşmak istedim.