Hücrelerdeki isimlere göre sayfa oluşturma

[drummers]

Kısa bir sorum olacaktı

Sayfa1 deki A1:A50 arasındaki hücrelerde yazılı olan isimleri nasıl bir makro ile sayfa yapabilirim.

Örnek:

A1= can olsun makro çalıştığında can isimli bir sayfa oluştursun

A2= ali olsun makro çalıştığında ali isimli bir sayfa oluştursun


Soru kısa olduğundan örnek dosya ekleme geriği duymadım...

 

[asi_kral]

Kısa bir sorum olacaktı

Sayfa1 deki A1:A50 arasındaki hücrelerde yazılı olan isimleri nasıl bir makro ile sayfa yapabilirim.

Örnek:

A1= can olsun makro çalıştığında can isimli bir sayfa oluştursun

A2= ali olsun makro çalıştığında ali isimli bir sayfa oluştursun


Soru kısa olduğundan örnek dosya ekleme geriği duymadım...

Merhaba
Boş bir module kopyalayın ve deneyin.

Option Explicit
Sub hücreden_sayfa_oluştur_1967()
'Konu       :   Hücrede Yazana Göre Sayfa Oluştur
'Mail       :   m.batu.1967@gmail.com
'Msn        :   m.batu.1967@hotmail.com.tr
'Coder By   :   asi_kral_1967
Dim asi As Long, kral As Variant, _
a As String, b As Long
Application.ScreenUpdating = False
a = ActiveSheet.Name
For asi = 1 To 50
For b = 1 To Sheets.Count
If Cells(asi, "A") <> Empty Then
If WorksheetFunction.CountIf(Range("A1:A" & asi), Sheets(b).Name) > 0 Then
kral = Cells(asi, "A")
Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Name = kral
Sheets(a).Select
End If: End If: Next: Next
Application.ScreenUpdating = True
MsgBox "İşlem Tamamlandı", vbInformation, "asi_kral_1967"
End Sub

 

[Ömer]

Merhaba,

Alternatif olsun.

Sayfa isimlerini, AnaSayfa adındaki sayfadan aldığı öngörülmüştür.

Sub SayfaAc()
 
    Dim i As Long, Sa As Worksheet
 
    Set Sa = Sheets("[COLOR=blue]AnaSayfa[/COLOR]")
 
    Application.ScreenUpdating = False
    Sa.Select
 
    For i = 1 To Cells(Rows.Count, "A").End(xlUp).Row
         If Cells(i, "A") <> "" And Not varmi(Cells(i, "A")) Then
            Sheets.Add(After:=Sheets(Sheets.Count)).Name = Sa.Cells(i, "A")
            Sa.Select
        End If
    Next i
 
End Sub
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function varmi(adi As String) As Boolean
    On Error Resume Next
    varmi = CBool(Len(Worksheets(adi).Name) > 0)
End Function

.

 

[drummers]

Merhaba,

Alternatif olsun.

Sayfa isimlerini, AnaSayfa adındaki sayfadan aldığı öngörülmüştür.

Sub SayfaAc()
 
    Dim i As Long, Sa As Worksheet
 
    Set Sa = Sheets("[COLOR=blue]AnaSayfa[/COLOR]")
 
    Application.ScreenUpdating = False
    Sa.Select
 
    For i = 1 To Cells(Rows.Count, "A").End(xlUp).Row
         If Cells(i, "A") <> "" And Not varmi(Cells(i, "A")) Then
            Sheets.Add(After:=Sheets(Sheets.Count)).Name = Sa.Cells(i, "A")
            Sa.Select
        End If
    Next i
 
End Sub
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function varmi(adi As String) As Boolean
    On Error Resume Next
    varmi = CBool(Len(Worksheets(adi).Name) > 0)
End Function

.

Teşekkürler

 

[haktem]

Merhaba benimde buna benzer bir şeye ihtiyacım vardı. Ben "D2" hücresinde yazan veri için sayfa oluşturmak istiyorum, yardımcı olur musunuz?

 

[Necdet]

Merhaba benimde buna benzer bir şeye ihtiyacım vardı. Ben "D2" hücresinde yazan veri için sayfa oluşturmak istiyorum, yardımcı olur musunuz?

Sadece boş bir sayfa mı yoksa belli bir şablona göre mi sayfa oluşturmak istiyorsunuz?

Sonradan boş bir sayfa işime yaramıyor demeyiniz sonra

 

[haktem]

Sadece boş bir sayfa mı yoksa belli bir şablona göre mi sayfa oluşturmak istiyorsunuz?

Sonradan boş bir sayfa işime yaramıyor demeyiniz sonra

Necdet Bey, aslında yapmak istediğim biraz fazla hatta bir konu http://www.excel.web.tr/f48/veri-aktarma-t114787.html açıp yardımda rica etmiştim, ilgilenen olmayınca bende parça parça yapmaya karar verdim. Kodları verirseniz üzerinde oynayarak bir şeyler yapabilirim.

Teşekkür ederim.

 

[haktem]

Necdet Bey, sadece boş bir sayfa oluşturacak şekilde kodu verebilirseniz, diğer işlemler için bulduğum kodları kullanarak birşeyler yapabilirim.

 

[Necdet]

Merhaba,

Aşağıdaki kodları ilgili sayfanın kod bölümüne kopyalayınız. D2 hücresi değiştikçe içeriğine göre sayfa oluşturacaktır.

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Sayfa   As String
 
    Sayfa = ActiveSheet.Name
 
    If Intersect(Target, [D2]) Is Nothing Then Exit Sub
    If Target.Value = "" Then Exit Sub
 
    If Not SayfaVarMi(Target.Value) Then
        Sheets.Add After:=Worksheets(Worksheets.Count)
        ActiveSheet.Name = Target.Value
        Sheets(Sayfa).Select
    End If
End Sub

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

 

[haktem]

Merhaba Necdet Bey,

Kodun "Sheets(BuSayfa).Select" kısımında hata verdi, birde bu kodu butona bağlayabilir miyiz? Hücre değiştiğinde değil de butona bastığımızda işlemi yapabilir miyiz?

Teşekkür ederim.

 

[Necdet]

Merhaba,

Aşağıdaki kodları bir modüle kopyalayıp deneyiniz.
Bulunduğunuz sayfanın adının "Sayfa1" olduğu varsayılmıştır. Dolayısı ile sayfa açtıktan sonra tekrar Sayfa1'e dönüş yapmaktadır.

Sub Sayfa_Ac()
 
    Dim Sayfa_Adi As String
 
    If [D2] = "" Then Exit Sub
    Sayfa_Adi = [D2]
 
    If Not SayfaVarMi(Sayfa_Adi) Then
        Sheets.Add After:=Worksheets(Worksheets.Count)
        ActiveSheet.Name = Sayfa_Adi
        Sheets("[COLOR=black]Sayfa1[/COLOR]").Select
    Else
        MsgBox Sayfa_Adi & " ADLI SAYFA ZATEN VAR, AÇILMADI...", vbInformation, "Necdet YEŞERTENER --> [URL="http://www.excel.web.tr/"]www.excel.web.tr[/URL]"
    End If
 
End Sub

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

 

[haktem]

Merhaba,

Aşağıdaki kodları bir modüle kopyalayıp deneyiniz.
Bulunduğunuz sayfanın adının "Sayfa1" olduğu varsayılmıştır. Dolayısı ile sayfa açtıktan sonra tekrar Sayfa1'e dönüş yapmaktadır.

Sub Sayfa_Ac()
 
    Dim Sayfa_Adi As String
 
    If [D2] = "" Then Exit Sub
    Sayfa_Adi = [D2]
 
    If Not SayfaVarMi(Sayfa_Adi) Then
        Sheets.Add After:=Worksheets(Worksheets.Count)
        ActiveSheet.Name = Sayfa_Adi
        Sheets("[COLOR=black]Sayfa1[/COLOR]").Select
    Else
        MsgBox Sayfa_Adi & " ADLI SAYFA ZATEN VAR, AÇILMADI...", vbInformation, "Necdet YEŞERTENER --> [URL="http://www.excel.web.tr/"]www.excel.web.tr[/URL]"
    End If
 
End Sub

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

Necdet Bey yardımınız için teşekkür ederim.