Yeni Çalışma Kitabı Oluştur. Sayfa 1'i olduğu gibi kaydet.

yeniyetme · 16 Mayıs 2008

Öncelikle bütün forum üyelerini selamlıyorum....

Ricam : Çok sayfalı (sheet) bir çalışma sayfam var. sayfa1 de sipariş formu var. Diğer sayfalarda ıvır zıvır şeyler var. Şimdi ben sayfa 1'e bir buton koysam. Bu butona tıkladığımda C:\sip klaöründe A1'de yazan değerde yeni bir çalışma kitabı oluştursa ,sayfa1'i bu yeni çalışma kitabına kopyalasa böyle bir örnek için yardım edebilirmisiniz? veya örnek alabileceğim linkler verebilirmisiniz. Bu istek için yeni bir konu açmazdım ama bu akşam bitirmem gerekiyor.

ilginize şimdiden teşekkür ederim..

yeniyetme · 16 Mayıs 2008

Sub farklikaydet()
Sheets("sheet1").Copy ***A1'den E'nin dolu olan son hücresine kadar
ActiveWorkbook.SaveAs ActiveWorkbook.Path & "\" & "onaylanan.xls"
**** a1 de yazan değer olacak
Set s1 = Workbooks("onaylanan.xls").Sheets("sheet1")
s1.[b3:b65536].SpecialCells(xlCellTypeBlanks).EntireRow.Delete
ActiveSheet.Shapes(1).Delete
ActiveWorkbook.Save
End Sub

*** la belirttiğim yerleri nasıl değiştirmeliyim...?

Ayhan Ercan · 16 Mayıs 2008

aşağıdaki gibi deneyiniz...

Kod:

Sub farklikaydet()
Dim sayfa
[COLOR=black]sayfa = [a1].Value[/COLOR]
[COLOR=black]Sheets("sheet1").Range("A1:E" & Sheets("SHEET1").[E65536].End(3).Row).Copy [/COLOR]
ActiveWorkbook.SaveAs ActiveWorkbook.Path & "\" & sayfa & ".xls"
Set s1 = Workbooks(sayfa & ".xls").Sheets("sheet1")
s1.[b3:b65536].SpecialCells(xlCellTypeBlanks).EntireRow.Delete
ActiveSheet.Shapes(1).Delete
ActiveWorkbook.Save
End Sub

yeniyetme · 16 Mayıs 2008

Ayhan Ercan' Alıntı:

aşağıdaki gibi deneyiniz...

Kod:

Sub farklikaydet()
Dim sayfa
[COLOR=black]sayfa = [a1].Value[/COLOR]
[COLOR=black]Sheets("sheet1").Range("A1:E" & Sheets("SHEET1").[E65536].End(3).Row).Copy [/COLOR]
ActiveWorkbook.SaveAs ActiveWorkbook.Path & "\" & sayfa & ".xls"
Set s1 = Workbooks(sayfa & ".xls").Sheets("sheet1")
s1.[b3:b65536].SpecialCells(xlCellTypeBlanks).EntireRow.Delete
ActiveSheet.Shapes(1).Delete
ActiveWorkbook.Save
End Sub

ilgi ve alakanıza çok teşekkür ederim ayhan bey....

yeniyetme · 17 Mayıs 2008

Sub lanetolsunicimdekicamsevgisine()
Columns("A:E").Copy
Workbooks.Add
ActiveSheet.Paste
ActiveWorkbook.SaveAs Filename:="D:\da\" & [A1].Value
End Sub

bu kodlarla ben sorunumu çözdüm.
Belki yeni olan başka arkadaşlarında işine yarayabilir...

yeniyetme · 17 Mayıs 2008

acaba bu kopyalamayı sayfa yapısı bozulmadan nasıl yapabilirim.
yeni yeni çalışma kitabındaki satır ve sutun genişlikleri aynı olsun.

copy satırını nasıl değiştirmeliyim..

yeniyetme · 17 Mayıs 2008

Soruları çok zor soruyorum galiba....?

Zeki Gürsoy · 17 Mayıs 2008

"sh" sabitinin adını yazıp proseduru çalıştırın.

Kod:

Sub Copy_To_New()
Dim wb As Workbook
Const sh As String = "Sayfa_Ad&#305;"

Set wb = Workbooks.Add

Sheets("" & sh).Copy before:=wb.Sheets(1)

Application.DisplayAlerts = False
For i = wb.Sheets.Count To 2 Step -1
    wb.Sheets(i).Delete
Next
Application.DisplayAlerts = True

wb.Sheets(1).Name = sh
wb.SaveAs "c:\sip\" & [a1] & ".xls"
wb.Close False

Set wb = Nothing
End Sub

yeniyetme · 17 Mayıs 2008

Zeki hocam örnek bir dosya ekleyebilirmisiniz acaba. Kodları çalıştırdığım zaman benim pc de yeni çalışma kitabı açıyor ve isim veriyor. Satır ve sutun genişliklerini kopyalamıyor. İki gündür bu ayrıntı için uğraşıyorum. hala çözemedim.

Zeki Gürsoy · 17 Mayıs 2008

Aktif dosya değişikliğinden kaynaklı hata almış olmalısınız. Biraz daha düzenledim.

Kod:

Sub test()
[COLOR=DarkGreen]'// Kullan&#305;m : kopyalanacak_sayfa, hedef, isim

[/COLOR]With ThisWorkbook
    Call Copy_To_New(.Sheets("Kopyalanacak"), "c:\sip\", _
        .Sheets("Uygulama").[a1].Value)
End With

End Sub

Private Sub Copy_To_New(sh As Worksheet, _
                        dst As String, _
                        fname As String)
Dim wb As Workbook

If Dir(dst & fname & ".xls") <> "" Then _
    MsgBox "'" & dst & fname & ".xls'" & _
        " mevcuttur!!!": Exit Sub
        
Set wb = Workbooks.Add

ThisWorkbook.Sheets("" & sh.Name).Copy before:=wb.Sheets(1)

Application.DisplayAlerts = False
For i = wb.Sheets.Count To 2 Step -1
    wb.Sheets(i).Delete
Next
Application.DisplayAlerts = True

wb.Sheets(1).Name = sh.Name
dst = IIf(Right$(dst, 1) = "\", dst, dst & "\")
wb.SaveAs dst & fname & ".xls"
wb.Close False

Set wb = Nothing
End Sub

Not : Biçimleriyle kopyalanıyor.

yeniyetme · 17 Mayıs 2008

Zeki hocam size nasıl teşekkür edeceğimi bilmiyorum.
Beni gerçekten çok mutlu ettiniz.
Allah tutuğunuzu altın etsin
Çalışmalarınızda başarılar dilerim.

Zeki Gürsoy · 17 Mayıs 2008

Siz de sağolun..

acebeci · 17 Mayıs 2008

Çok değerli arkadaşlar bu konu benim de çok işime yarayacak ama biraz değişiklik yapmak gerekecek yardımcı olabilirseniz çok sevinirim benim isteğim

1-çalışma kitabım da liste isminde bir sayfam var bu sayfadaki veriler hergün değişiyor verilerim a1 ile g5000 aralığında h1 hücresinde ise o günün tarihi var
2-bu verilerimi d:\YEDEK diye oluşturduğum klasörüme hergün akşam yedeklemek istiyorum
3-burda onemli olan her yeni tarih için yeni bir yedek oluşturması lazım her yeni oluşturduğum yedeğe h1 hücresindeki tarihin ismini verebilir
4-bu çalışmaları çalışma sayfalarına(sayfa1 i mesala 17.05.08 sayfa 2 yi 18.05.08 diye gidebilir.yada her tarihe yeni çalışma kitabı açablir hangisi kolay olursa o şekilde olabilir ,
Eğer böyle bir çalışma yapılabilirse yardımcı olursanız çok sevinirim

Zeki Gürsoy · 17 Mayıs 2008

acebeci' Alıntı:
Çok değerli arkadaşlar bu konu benim de çok işime yarayacak ama biraz değişiklik yapmak gerekecek yardımcı olabilirseniz çok sevinirim benim isteğim

1-çalışma kitabım da liste isminde bir sayfam var bu sayfadaki veriler hergün değişiyor verilerim a1 ile g5000 aralığında h1 hücresinde ise o günün tarihi var
2-bu verilerimi d:\YEDEK diye oluşturduğum klasörüme hergün akşam yedeklemek istiyorum
3-burda onemli olan her yeni tarih için yeni bir yedek oluşturması lazım her yeni oluşturduğum yedeğe h1 hücresindeki tarihin ismini verebilir
4-bu çalışmaları çalışma sayfalarına(sayfa1 i mesala 17.05.08 sayfa 2 yi 18.05.08 diye gidebilir.yada her tarihe yeni çalışma kitabı açablir hangisi kolay olursa o şekilde olabilir ,
Eğer böyle bir çalışma yapılabilirse yardımcı olursanız çok sevinirim

Bunun gibi olabilir. H1 yerine otomatik olarak günün tarihi de alınabilir.

Kod:

Sub auto_open()
[COLOR=DarkGreen]'// her gün 17:00:00 da test isimli prosedur çalışacak..[/COLOR]
    Application.OnTime TimeValue("17:00:00"), "test"
End Sub

Sub test()
[COLOR=DarkGreen]'// Kullanım : kopyalanacak_sayfa, hedef, isim[/COLOR]

Dim arr() As Variant, i As Byte
[COLOR=DarkGreen]'// Sayfa isimleri dizisi..[/COLOR]
arr = Array("Sayfa1", "Sayfa2")

With ThisWorkbook
    For i = 0 To UBound(arr)

        Call Copy_To_New(.Sheets("" & arr(i)), "d:\yedek\", _
            .Sheets("" & arr(i)).Name & _
            "_" & CStr(.Sheets("" & arr(i)).[h1].Value))
        [COLOR=DarkGreen] '// Örnek çıktı ismi: d:\yedek\Sayfa1_17.05.08.xls[/COLOR]
    Next
End With
End Sub

Private Sub Copy_To_New(sh As Worksheet, _
                        dst As String, _
                        fname As String)
Dim wb As Workbook

If Dir(dst & fname & ".xls") <> "" Then _
    MsgBox "'" & dst & fname & ".xls'" & _
        " mevcuttur!!!": Exit Sub
        
Set wb = Workbooks.Add

ThisWorkbook.Sheets("" & sh.Name).Copy before:=wb.Sheets(1)

Application.DisplayAlerts = False
For i = wb.Sheets.Count To 2 Step -1
    wb.Sheets(i).Delete
Next
Application.DisplayAlerts = True

wb.Sheets(1).Name = sh.Name
dst = IIf(Right$(dst, 1) = "\", dst, dst & "\")
wb.SaveAs dst & fname & ".xls"
wb.Close False

Set wb = Nothing
End Sub

acebeci · 17 Mayıs 2008

Sayın Zeki Bey konuya göstermiş olduğunuz ilgiden dolayı çok teşekkür ederim.
Zeki Bey bu yedekleme işini otamatik değilde bir tuşa bağlayıp benim istediğim bir zaman da yapabilirsek çok süper olacak.çünki o güne ait bilgileri son anki durumu ile yedeklemem lazım o yüzden gün içinde bilgilerin ne zaman değişeceğini tam bilemiyoruz belge son halini alınca tuşa basıp yedeklemek istiyorum
Birde şöyle bir sorun var biraz öncki kodu çalışmama uygulayamadım bilgileri d:\yedek isimli klasöre atmak istiyorum ama galiba biryerlerde yanlış yaptım.
Eğer bu söylediğim gibi bir çalışma oluşturulabilirse çok süper olacak şimdiden çok ama çok teşekkür edrim

Zeki Gürsoy · 17 Mayıs 2008

Öyleyse "auto_open" prosedurunu silin. "test" isimli proseduru de bir buton ile çağırırsanız istediğiniz gibi olur.

Eğer hata oluştuysa hata satırını ve hata iletisini belirtin. (arr dizi değişkenindeki sayfa isimlerini kendi dosyanızdaki sayfa isimlerine göre düzenlemeyi unutmayın.)

yeniyetme · 17 Mayıs 2008

Zeki bey siz çok değerli bir adamsınız ?
Klavyenize sağlık...

acebeci · 17 Mayıs 2008

Sayın Zeki bey şimdi ben kodlarla yeni yeni çalışmaya başladığım için birtürlü işin içinden çıkamıyorum bu sizin için çok kolay bir konudur eminim ama inanın beni baya patinaj ettiriyor Affınıza sığınarak
arr dizi değişkenindeki sayfa isimlerini kendi dosyama göre uyarlayamadım

Call Copy_To_New(.Sheets("" & arr(i)), "d:\yedek\", _
.Sheets("" & arr(i)).Name & _
"_" & CStr(.Sheets("" & arr(i)).[h1].Value))
'// Örnek çıktı ismi: d:\yedek\Sayfa1_17.05.08.xls

burayı bir türlü uyarlayamadım(Tabi burdan başaka benim eklemem gereken başka yer varsa onuda bilmiyorum.)
ben deneme adlı çalışma kitabındaki liste isimli sayfadaki verileri d: diskindeki ARŞİV adlı klasördeki YEDEK isimli excel çalışma kitabına (Yedek çalışma kitabının neresi olursa olsun)yedeklemek istiyorum.
Verdiğim Rahatsızlıkdan dolayı özür diler çalışmalarınız da başarılar dilerim

yeniyetme · 2 Haziran 2008

Zeki Gürsoy' Alıntı:

Aktif dosya değişikliğinden kaynaklı hata almış olmalısınız. Biraz daha düzenledim.

Kod:

Sub test()
[COLOR=DarkGreen]'// Kullanım : kopyalanacak_sayfa, hedef, isim

[/COLOR]With ThisWorkbook
    Call Copy_To_New(.Sheets("Kopyalanacak"), "c:\sip\", _
        .Sheets("Uygulama").[a1].Value)
End With

End Sub

Private Sub Copy_To_New(sh As Worksheet, _
                        dst As String, _
                        fname As String)
Dim wb As Workbook

If Dir(dst & fname & ".xls") <> "" Then _
    MsgBox "'" & dst & fname & ".xls'" & _
        " mevcuttur!!!": Exit Sub
        
Set wb = Workbooks.Add

ThisWorkbook.Sheets("" & sh.Name).Copy before:=wb.Sheets(1)

Application.DisplayAlerts = False
For i = wb.Sheets.Count To 2 Step -1
    wb.Sheets(i).Delete
Next
Application.DisplayAlerts = True

wb.Sheets(1).Name = sh.Name
dst = IIf(Right$(dst, 1) = "\", dst, dst & "\")
wb.SaveAs dst & fname & ".xls"
wb.Close False

Set wb = Nothing
End Sub

Not : Biçimleriyle kopyalanıyor.

Sayın Zeki hocam bu soruyu sormak için biraz geç kaldım ama

olsun..
Yeni çalışma kitabına kayıt yaparken 1 sayfalık bir bilgi bile olsa 3, kusur mb'lık bir alan kaplıyor...
Bende dolu olan en son satırdan sonraki ilk satırdan başlayarak 65536 ya kadar olan satırları elle siliyorum....
o zaman dosya boyutu 35 kb 'ye kadar düşüyor...
Bende elle silmemek için şu kodları buldum sizin verdiğiniz kodlara entegre etmeye çalıştım ama beceremedim...Aşağıdaki kodları hangi kısma yazmam gerekiyor acaba...

sonsatir = [A65536].End(3).Row
Rows("sonsatir:65000").Delete Shift:=xlUp

Zeki Gürsoy · 2 Haziran 2008

Aşağıdaki mavi kısmın ilavesiyle sorununuz çözülüyor sanırım.

Kod:

Sub test()
[COLOR=DarkGreen]'// Kullanım : kopyalanacak_sayfa, hedef, isim

[/COLOR]With ThisWorkbook
    Call Copy_To_New(.Sheets("Kopyalanacak"), "c:\sip\", _
        .Sheets("Uygulama").[a1].Value)
End With

End Sub

Private Sub Copy_To_New(sh As Worksheet, _
                        dst As String, _
                        fname As String)
Dim wb As Workbook

If Dir(dst & fname & ".xls") <> "" Then _
    MsgBox "'" & dst & fname & ".xls'" & _
        " mevcuttur!!!": Exit Sub
        
Set wb = Workbooks.Add

ThisWorkbook.Sheets("" & sh.Name).Copy before:=wb.Sheets(1)

Application.DisplayAlerts = False
For i = wb.Sheets.Count To 2 Step -1
    wb.Sheets(i).Delete
Next
Application.DisplayAlerts = True

[COLOR=Blue][B] sonsatir = wb.Sheets(1).[A65536].End(3).Row + 1
wb.Sheets(1).Rows("" & sonsatir & ":65536").Delete[/B][/COLOR]

wb.Sheets(1).Name = sh.Name
dst = IIf(Right$(dst, 1) = "\", dst, dst & "\")
wb.SaveAs dst & fname & ".xls"
wb.Close False

Set wb = Nothing
End Sub

Yeni Çalışma Kitabı Oluştur. Sayfa 1'i olduğu gibi kaydet.

yeniyetme

yeniyetme

Ayhan Ercan

Özel Üye

yeniyetme

yeniyetme

yeniyetme

yeniyetme

Zeki Gürsoy

Uzman

yeniyetme

Zeki Gürsoy

Uzman

yeniyetme

Zeki Gürsoy

Uzman

acebeci

Zeki Gürsoy

Uzman

acebeci

Zeki Gürsoy

Uzman

yeniyetme

acebeci

yeniyetme

Zeki Gürsoy

Uzman