Excel içerisindeki bir kağıdı yeni açılan boş excel kitabına aktarma makrosu

[manyakbiri]

Arkadaşlar merhaba,

İçinde çalıştığımız exceldeki kağıdı apayrı bir çalışma kitabına almak istiyorum. İstediğim makro, daha önce bilgisayarımda kayıtlı olmayan, sıfırdan, yeni bir excel kitabı açacak ve transfer etmek istediğim excel kağıdını (kağıt ait olduğu dosyada da kalacak şekilde) yeni açılan excel kitabına alacak.

Makro Kaydet yolu ile bu makroyu yazmayı denedim. Makroda her zaman Kitap1 ismi ile yeni kitap açtığı için , bu problem oluşturuyor. Kimi zaman excel Kitap2 ismi ile de dosya açabiliyor ve makro çalışmıyor.

İstediğim makronun kodlarını benimle paylaşırsanız memnun olurum.

Cevaplarınızı bekleyeceğim.

 

[turist]

Deneyin.

Option Explicit
Sub SayfayıKitabaKopyala()
    Dim YeniKitap As String, HangiSayfa As String
    Dim nm As Name
    Dim ws As Worksheet

    If MsgBox("Yeni bir Çalışma Kitabına Kopyalayacağınız Sayfanın;" & vbCr & _
    "Tanımlı alan adları , köprü ve formülleri kaybolur, sadece sayfadaki değerler aktarılır" _
    , vbYesNo, "Kopyalansın mı?") = vbNo Then Exit Sub
    With Application
        .ScreenUpdating = False
        On Error GoTo Hata
      HangiSayfa = InputBox("Hangi Sayfa Kopyalanacak?", "SAYFA")
       Sheets(HangiSayfa).Copy
        On Error GoTo 0
        For Each ws In ActiveWorkbook.Worksheets
            ws.Cells.Copy
            ws.[A1].PasteSpecial Paste:=xlValues
            ws.Cells.Hyperlinks.Delete
            Application.CutCopyMode = False
            Cells(1, 1).Select
            ws.Activate
        Next ws
        Cells(1, 1).Select
        For Each nm In ActiveWorkbook.Names
            nm.Delete
        Next nm
        YeniKitap = InputBox("Çalışma Kitabına bir isim veriniz!", "Yeni Çalışma Kitabı")
        ActiveWorkbook.SaveCopyAs ThisWorkbook.Path & "\" & YeniKitap & ".xlsx"
        ActiveWorkbook.Close SaveChanges:=False
        .ScreenUpdating = True
    End With
    Exit Sub
Hata:
    MsgBox "Bu çalışma kitabında ' " & HangiSayfa & " ' isimli bir sayfa bulunamadı"
End Sub

 

[manyakbiri]

Öncelikle çok teşekkür ederim. Yazdığınız kod son derece kullanışlı, üstelik raporu ayrı bir kitaba almakla kalmıyor doğrudan desktop'a kayıt ediyor.

Daha kullanışlı olması açısından söz edeceğim düzenleme yapılabilir mi acaba ?

Benim başka bir excel dosyasına almak istediğim sheet'in ismi hiç değişmiyor, ismi her zaman Rapor. Bana bu makroyu çalıştırdığımda, Hangi Sayfa Kopyalanacak sorusu hiç sorulmasa ve direkt Rapor ismindeki sekme aktarılsa yeni kitaba. Bu yapılabilirse eğer çok daha amaca yönelik bir makro hazırlanmış olur. Bununla beraber Kopyalansın mı? uyarısının çıkmasına da gerek yok. Bu işi ben kendim de yapsam veri olarak yapıştıracaktım sheeti tamamen. Makro da zaten veri olarak yapıştırmak üzere yazılmış. Bu uyarıyı da kaldırabiliriz diye düşünüyorum.

İlginiz ve desteğiniz için yeniden teşekkür ediyorum, yanıtınızı bekleyeceğim.

 

[turist]

Option Explicit
Sub SayfayıKitabaKopyala()
    Dim YeniKitap As String
    Dim nm As Name
    Dim ws As Worksheet
    With Application
        .ScreenUpdating = False
        On Error GoTo Hata
       Sheets("Rapor").Copy
        On Error GoTo 0
        For Each ws In ActiveWorkbook.Worksheets
            ws.Cells.Copy
            ws.[A1].PasteSpecial Paste:=xlValues
            ws.Cells.Hyperlinks.Delete
            Application.CutCopyMode = False
            Cells(1, 1).Select
            ws.Activate
        Next ws
        Cells(1, 1).Select
        For Each nm In ActiveWorkbook.Names
            nm.Delete
        Next nm
        YeniKitap = InputBox("Çalışma Kitabına bir isim veriniz!", "Yeni Çalışma Kitabı")
        If YeniKitap = "" Then
        ActiveWorkbook.Close SaveChanges:=False
        Else
        ActiveWorkbook.SaveCopyAs ThisWorkbook.Path & "\" & YeniKitap & ".xlsx"
        ActiveWorkbook.Close SaveChanges:=False
        .ScreenUpdating = True
        End If
    End With
    Exit Sub
Hata:
End Sub

 

[manyakbiri]

Çok teşekkürler. Bu forumu ve yardımsever üyelerini seviyorum.