Yazılan isimlere şablonun atanması

[SeLDa]

Merhaba;

Yeni bir çalışma hazırlıyorum. Burada takıldığım iki nokta var.

1 – Çalışma kitabının Sayfa2’de hazırladığım örnek bir şablonum mevcut. Bu şablonu makrolar ve formüllerde dâhil olmak üzere Sayfa1’in A sütununa alt alta yazdığım isimlere otomatik olarak atanmasını ve bütün isimlerin ayrı bir sayfada açılmasını istiyorum.

2 – Sayfa1 de ( A sütununda ) alt alta yazılan karışık isimlerin alfabetik sıraya göre kendi kendini düzenlemesini istiyorum.

Yardımcı olabilirseniz çok sevinirim.

Şimdiden teşekkür ederim.

 

[Korhan Ayhan]

Selamlar,

Örnek bir dosya eklemeniz mümkünmü?

 

[SeLDa]

eklediğim örnek dosyada formüller ve makrolar bulunmuyor. Sadece taslar olarak verdim.

teşekkür ederim.

 

[Korhan Ayhan]

Selamlar,

A sütunundaki hücreye isim ekledikçe mi sayfa açılacak yoksa bütün isimleri yazıp alfabetik sıralandıktan sonra bir tuşa basıncamı açılmasını istiyorsunuz?

 

[SeLDa]

A sütununa isim eklendiğinde Sayfa açılabilir. daha sonrada alfabetik sıralama olabilir.

Ama yine de fark etmez iki yönlüde olabilir. Sizin için hangisi kolay olursa o olsun.

 

[Korhan Ayhan]

Selamlar,

Ekte örnek bir dosya hazırladım. A sütununa veri girdikçe sayfa ekler ve A sütununu alfabetik sıralar eğer aynı isimde sayfa mevcutsa uyarı verir.

 

[SeLDa]

Sn. COST_CONTROL

Bu harika bir çalışma olmuş. Emeğiniz için çok teşekkür ederim.

 

[SeLDa]

Merhaba;

Kodları gerçek dosyaya ekledim. Yine sayfa isimleri Giriş ve Örnek Şablon olarak geçiyor. Fakat isimler B8 hücresinden başlıyor. Uyguladığınız koda göre B8 den başlattım yani ordaki kodu değiştirdim ama olmadı.

Nerde yanlış yapıyorum acaba.

Yardımcı olabilirmisiniz.

 

[Korhan Ayhan]

Selamlar,

Dosyanızı eklerseniz yardımcı olmaya çalışırım.

 

[SeLDa]

Teşekkür ederim.

 

[Korhan Ayhan]

Selamlar,

Aşağıdaki kodu uygulayınız.

Private Sub Worksheet_Change(ByVal Target As Range)
    Application.ScreenUpdating = False
    On Error Resume Next
    If Intersect(Target, [B8:B65536]) Is Nothing Then Exit Sub
    If Target.Value = "" Then Exit Sub
    On Error GoTo Devam
    Sheets(Target.Text).Select
    MsgBox "BU İSİMDE BİR SAYFA MEVCUTTUR.", vbCritical
    Sheets("Giriş").Select
    Target.Select
    Application.ScreenUpdating = True
    Exit Sub

Devam:
    Sheets("Örnek Şablon").Copy After:=Sheets(Sheets.Count)
    Sheets(Sheets.Count).Name = Target.Text
    Sheets("Giriş").Select
    Range("B8:B65536").Select
    Selection.Sort Key1:=Range("B8"), Order1:=xlAscending, Header:=xlNo, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
    Range("B8").Select
    Do While Not IsEmpty(ActiveCell)
    ActiveCell.Offset(1, 0).Select
    Loop
    Application.ScreenUpdating = True
End Sub

 

[SeLDa]

Çok teşekkür ediyorum.

Son bir şey daha isteyebilirmiyim. B sütununa yazdığımız isimlerin üstüne tıklayarak sayfalarını açabilirmiyiz acaba.

 

[Korhan Ayhan]

Selamlar,

Bu durumda son verdiğim kodun yerine aşağıdaki kodu kullanmalısınız.

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    Application.ScreenUpdating = False
    On Error Resume Next
    If Intersect(Target, [B8:B65536]) Is Nothing Then Exit Sub
    If Target.Value = "" Then
    Cancel = True
    Exit Sub
    End If
    On Error GoTo Devam
    Cancel = True
    Sheets(Target.Text).Select
    MsgBox "BU İSİMDE BİR SAYFA MEVCUTTUR.", vbCritical
    Sheets("Giriş").Select
    Target.Select
    Application.ScreenUpdating = True
    Exit Sub

Devam:
    Cancel = True
    Sheets("Örnek Şablon").Copy After:=Sheets(Sheets.Count)
    Sheets(Sheets.Count).Name = Target.Text
    Sheets("Giriş").Select
    Range("B8:B65536").Select
    Selection.Sort Key1:=Range("B8"), Order1:=xlAscending, Header:=xlNo, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
    Range("B8").Select
    Do While Not IsEmpty(ActiveCell)
    ActiveCell.Offset(1, 0).Select
    Loop
    Application.ScreenUpdating = True
End Sub

 

[SeLDa]

Sanırım yanlış anlattım. Ben sayfa açıldıkdan sonra kişinin sayfasına ismini tıklayarak girip işlem yapabilirmiyim diye anlatmaya çalışmıştım. Yani sayfa sekmasini tıklayark değilde ismini tklayarak sayfasına erişebilirmiyim.

Sayfa sekmelerini gizlemeyi düşünüyorum çünkü..

Uğraştırıyorum sizi özür dilerim.

 

[Korhan Ayhan]

Selamlar,

Evet biraz uğraştık sorununuzla bu tür sorularınızda isteklerinizi net olarak belirtirseniz benim dışımda cevap vermek isteyen arkadaşlarımız için kolaylık olacağını düşünüyorum. Sizin ifadenizi şu şekilde yorumladım. A sütununa yazacağınız isimle sayfa ekleyip bu sayfaya link vermek istiyorsunuz. Eğer bu şekilde ise aşağıdaki kodu kullanabilirsiniz.

Private Sub Worksheet_Change(ByVal Target As Range)
    Application.ScreenUpdating = False
    On Error Resume Next
    If Intersect(Target, [B8:B65536]) Is Nothing Then Exit Sub
    If Target.Value = "" Then Exit Sub
    On Error GoTo Devam
    Sheets(Target.Text).Select
    MsgBox "BU İSİMDE BİR SAYFA MEVCUTTUR.", vbCritical
    Sheets("Giriş").Select
    Target = ""
    Target.Select
    Application.ScreenUpdating = True
    Exit Sub

Devam:
    Sheets("Örnek Şablon").Copy After:=Sheets(Sheets.Count)
    Sheets(Sheets.Count).Name = Target.Text
    Sheets("Giriş").Select
    ActiveSheet.Hyperlinks.Add Anchor:=Target, Address:="", _
    SubAddress:=Target.Text & "!A1", TextToDisplay:=Target.Text
    Range("B8:B65536").Select
    Selection.Sort Key1:=Range("B8"), Order1:=xlAscending, Header:=xlNo, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
    Range("B8").Select
    Do While Not IsEmpty(ActiveCell)
    ActiveCell.Offset(1, 0).Select
    Loop
    Application.ScreenUpdating = True
End Sub

 

[SeLDa]

Teşekkür ederim. Haklısınız.

Yalnız isime link veriyor ama sayfayı açmıyor. Başvuru geçerli değil diyor.

 

[SeLDa]

Tamam sorun çözüldü. Çok teşekkür ederim.

Emeğinize sağlık.

Kolay gelsin.

 

[SeLDa]

Sorun çözüldü dedim ama çözülmedi. Yani kısmen çözülmedi.

Şöyleki ;

Misal veriyorum.

Mehmet ( yazdığım zaman isime link veriyor ve sayfası açılıyor)

Mehmet Sağ (yazdığımda isime link veriyor fakat başvuru geçerli değil diye hata verip sayfasını açmıyor)

Tek bir isimde açıyor. A Soyad yazıldığında açılmıyor.

 

[Korhan Ayhan]

Selamlar,

Hatanın nerden kaynaklandığını tesbit ettim makro kaydet yöntemi ile köprü kurduğumda iki isimli sayfaların isminin başına ve sonuna tek tırnak işareti ekliyor bu eklemeyi koda uyarlayınca aşağıdaki kod oluştu "Mehmet" ve "Mehmet SAĞ" olarak denedim sağlıklı çalışıyor.

Private Sub Worksheet_Change(ByVal Target As Range)
    Application.ScreenUpdating = False
    On Error Resume Next
    If Intersect(Target, [B8:B65536]) Is Nothing Then Exit Sub
    If Target.Value = "" Then Exit Sub
    On Error GoTo Devam
    Sheets(Target.Text).Select
    MsgBox "BU İSİMDE BİR SAYFA MEVCUTTUR.", vbCritical
    Sheets("Giriş").Select
    Say = WorksheetFunction.CountIf([B8:B65536], Target.Text)
    If Say > 1 Then
    Target = ""
    Target.Select
    Else
    Target.Select
    Application.ScreenUpdating = True
    Exit Sub
Devam:
    Sheets("Örnek Şablon").Copy After:=Sheets(Sheets.Count)
    Sheets(Sheets.Count).Name = Target.Text
    Sheets("Giriş").Select
    ActiveSheet.Hyperlinks.Add Anchor:=Target, Address:="", _
    SubAddress:="'" & Target.Text & "'" & "!A1", TextToDisplay:=Target.Text
    Range("B8:B65536").Select
    Selection.Sort Key1:=Range("B8"), Order1:=xlAscending, Header:=xlNo, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
    Range("B8").Select
    Do While Not IsEmpty(ActiveCell)
    ActiveCell.Offset(1, 0).Select
    Loop
    Application.ScreenUpdating = True
    End If
End Sub

Edit : Kodda ufak bir revize yaptım. Say değişkenini ekledim.

 

[SeLDa]

Çok teşekkür ederim.