Makro ile toplu halde sayfa açıp isimlendirme.

Katılım
17 Ekim 2011
Mesajlar
490
Excel Vers. ve Dili
Excel 2003 - Türkçe
Merhabalar

Aşağıdaki şekilde bir kod buldum lakin tam olarak istediğim işlemi yapmıyor.

Ekli dosyada da belirttiğim gibi
C sütununa gireceğim verile göre sayfa açmasını ve
isimlendirmesini istiyorum.

Yeni açacağı sayfayı
makroyu çalıştıracağımız sayfayı herşeyiyle kopyalayarak
oluşturacak

Şayet el altında link var ise link paylaşımı yok ise eğer
Konuya hakim değerli üstadların yardımlarını bekliyorum

saygılarımla.

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Sheets("Sayfa1").Range("A1") = Empty Then
For i = 1 To Worksheets.Count
If Sheets(i).Name = Sheets("Sayfa1").Range("A1") Then
MsgBox "Bu isimli bir sayfa mevcut..... !"
Exit Sub
End If
Next
Set NewSh = Worksheets.Add(After:=Sheets(Sheets.Count))
NewSh.Name = Sheets("Sayfa1").Range("A1")
End If
Sheets("Sayfa1").Select
Range("A1").Select
Selection.ClearContents
Set NewSh = Nothing
End Sub
 

Ekli dosyalar

Katılım
17 Ekim 2011
Mesajlar
490
Excel Vers. ve Dili
Excel 2003 - Türkçe
Merhabalar

Halan aramaktayım arkadaşlar bu makroya ihtiyacım var.
Daha önceden yapılmış farkıl farklı makrolar bulmaktayım.
Lakin benim istediğim kriterlere uyan yok. Bulduklarımı da kendimde
uyarlayamıyorum.

Yazacağımız makro modülde olacak.
Makro ile butonu koyduğumuz sayfayı kopyalayıp yeni çalışma sayfaları
oluşturacağız. Oluşturduğumuz yeni sayfaları
C sütunundaki veriler ile isimlendireceğiz.

yardımlarınızı bekliyorum.
 

mancubus

Destek Ekibi
Destek Ekibi
Katılım
6 Ocak 2010
Mesajlar
2,224
Excel Vers. ve Dili
İŞ: 2021 Win Eng
merhaba.

standart kod modülüne:

Kod:
Sub Sayfa_Kopyala()

Dim ws As Worksheet
Dim wsName As String

Set ws = Worksheets("Hülya") 'kopyalanacak şablon sayfanın ismi tırnak içinde buraya
With ws
    For i = 3 To .Cells(Rows.Count, 3).End(xlUp).Row
        wsName = .Cells(i, 3).Value
        If Not SheetExists(wsName) Then .Copy After:=Worksheets(Worksheets.Count)
        ActiveSheet.Name = wsName
    Next
End With

End Sub

Function SheetExists(shName As String) As Boolean
    On Error Resume Next
    SheetExists = CBool(Len(Worksheets(shName).Name) > 0)
End Function
sonra oluşturulacak bir komut düğmesine makro atama ile Sayfa_Kopyala makrosu atanabilir.

veya arzu edilir ise Sayfa_Kopyala içindeki kodlar düğme koduna aktarılabilir.
 
Katılım
17 Ekim 2011
Mesajlar
490
Excel Vers. ve Dili
Excel 2003 - Türkçe
Merhabalar
Sayın mancubus
kod çok süper olmuş tam istediğim gibi.
Ellerinize sağlık teşekkür ederim.

Özür dilerim. Benim açıklamalarımdan kaynaklanan küçük bir detay var.
Düzeltilebilrse kodumuz çok daha süper olur.

Oluşturulacak yeni sayfaların isimlerini kopyalanmasını istediğimiz
sayfanın içinde C sütununa yazıyor idik. Bu şekilde olduğu zaman
Mevzu listeyi ve Kullandığımız butonuda kopyalıyor. Ve Bunları silmek zorunda
kalıyorum ki sayfa sayısı çok fazla olduğu için angarya epeyce fazla oluyor.

Daha sonradan silmek üzere herhangi bir sayfa belirleyip makromuzu bu
sayfadan çalıştırsak sanırım bu sorunu halletmiş oluruz.
 
Son düzenleme:

mancubus

Destek Ekibi
Destek Ekibi
Katılım
6 Ocak 2010
Mesajlar
2,224
Excel Vers. ve Dili
İŞ: 2021 Win Eng
ben onun özellikle istendiğini düşünmüştüm.

aşağıdakini deneyelim...

Kod:
Sub Sayfa_Kopyala()

Dim ws As Worksheet
Dim wsName As String

Application.CopyObjectsWithCells = False
Set ws = Worksheets("Hülya") 'kopyalanacak şablon sayfanın ismi tırnak içinde buraya
With ws
    For i = 3 To .Cells(Rows.Count, 3).End(xlUp).Row
        wsName = .Cells(i, 3).Value
        If Not SheetExists(wsName) Then .Copy After:=Worksheets(Worksheets.Count)
        ActiveSheet.Name = wsName
    Next
End With
Application.CopyObjectsWithCells = True

End Sub
 
Katılım
17 Ekim 2011
Mesajlar
490
Excel Vers. ve Dili
Excel 2003 - Türkçe
Sayın mancubus

Ben kodu çalıştıramadım.
Hem kopyalanacak sayfada denedim
hemde başka bir sayfada denedim hata veriyor.

Siz örnek dosyaya uygulayabilirmisiniz acaba
 

mancubus

Destek Ekibi
Destek Ekibi
Katılım
6 Ocak 2010
Mesajlar
2,224
Excel Vers. ve Dili
İŞ: 2021 Win Eng
ben sizin dosyasa deneyerek çalıştığını gördükten sonra buraya kopyaladım.

3 no.lu mesajdaki kullanıcı tanımlı fonksiyonu silmiş olabilir misiniz.

bu kod da bulunmalı.

Kod:
Function SheetExists(shName As String) As Boolean
    On Error Resume Next
    SheetExists = CBool(Len(Worksheets(shName).Name) > 0)
End Function
 
Katılım
17 Ekim 2011
Mesajlar
490
Excel Vers. ve Dili
Excel 2003 - Türkçe
Sayın mancubus

Kodlarda herhangi bir şey silmedim.
Lakin son makroda şunu gözlemledim.

Örenek dosyamıza göre konuşur isek.
Buton Sayfa1 de
İsim atayacağız veriler ise Hülya sayfasında.
olduğu zaman çalışıyor.

Ben isim atayacağımız verilerinde Sayfa1 de olmasını istiyorum.

Kopyalayacağımız sayfa deaktifken
Kopyalayacağımız sayfanın ismini makroya yazarak kopyalama yapabilelim.
umarım anlatabildim.
 
Katılım
17 Ekim 2011
Mesajlar
490
Excel Vers. ve Dili
Excel 2003 - Türkçe
Sayın mancubus

Çok özür diliyorum. Açıklama zafiyetinden dolayı
extradan iş çıkardım size.

Dosyayı tekrardan yüklüyorum.
 

Ekli dosyalar

Son düzenleme:

mancubus

Destek Ekibi
Destek Ekibi
Katılım
6 Ocak 2010
Mesajlar
2,224
Excel Vers. ve Dili
İŞ: 2021 Win Eng
dosya ektedir.

Kod:
Sub Sayfa_Kopyala()

    Dim ws As Worksheet
    Dim wsName As String
    
    Set ws = Worksheets("Sayfa1") 
    Application.CopyObjectsWithCells = False
    For i = 3 To ws.Cells(Rows.Count, 3).End(xlUp).Row
        wsName = ws.Cells(i, 3).Value
        If Not SheetExists(wsName) Then Worksheets("Hülya").Copy After:=Worksheets(Worksheets.Count)
        ActiveSheet.Name = wsName
    Next
    Application.CopyObjectsWithCells = True

End Sub



Function SheetExists(shName As String) As Boolean
    On Error Resume Next
    SheetExists = CBool(Len(Worksheets(shName).Name) > 0)
End Function
 

Ekli dosyalar

Katılım
17 Ekim 2011
Mesajlar
490
Excel Vers. ve Dili
Excel 2003 - Türkçe
Budur :)

Değerli Üstad.

Eline beynine sağlık.
Allah ne muradın varsa versin inşallah.
 

mancubus

Destek Ekibi
Destek Ekibi
Katılım
6 Ocak 2010
Mesajlar
2,224
Excel Vers. ve Dili
İŞ: 2021 Win Eng
amin. cümlemize. iyi günler...
 
Üst