Soru Seçili Hücredeki İsimlerle Sekme isimleri verme/oluşturma

[metince54]

sayfa 1 deki hücreleri seçildiğinde oradaki yazılı olanlarla sekmeler oluşup o isimde olabilir mi.
örnek elma armut muz kavun karpuz yazılı hücreleri seçtim kodu çalıştırdım bana yazılı olanlarla sekme açılsın istiyorum.

 

[vurkan]

Merhaba yanlış anlamadıysam daha önce benin isteğimle yazılan kodları uyarlayıp bir dosya hazırladım.


http://s3.dosya.tc/server16/6htk4b/B_YE_GORE_SAYFA_AC.rar.html

Bir buton yardımıyla yapmak istersen;

http://s3.dosya.tc/server16/34o0w8/B_YE_GORE_SAYFA_AC_2.rar.html

(Not: Burada verdiğim kodlar bu Forumdaki değerli üstadlara aittir. )

 

[metince54]

şuanda bakamıyorum bakıp size döneceğim. ilginiz için şimdiden çok teşekkür ederim

 

[kalpersak]

Merhaba yanlış anlamadıysam daha önce benin isteğimle yazılan kodları uyarlayıp bir dosya hazırladım.


http://s3.dosya.tc/server16/6htk4b/B_YE_GORE_SAYFA_AC.rar.html

Bir buton yardımıyla yapmak istersen;

http://s3.dosya.tc/server16/34o0w8/B_YE_GORE_SAYFA_AC_2.rar.html

(Not: Burada verdiğim kodlar bu Forumdaki değerli üstadlara aittir. )

Çok teşekkür ederim

 

[vurkan]

Rica ederim. Sorununuzun çözülmesine sevindim.

 

[yyhy]

Arkadaşlar 1. linki indirdim. Ama 2. Link dosya kaldırılmış gözüküyor.
1. Dosyayı indirdim ekleyen arkadaşa ve emeği geçenlere teşekkür ederim. Güzel bir çalışma olmuş.

 

[vurkan]

Merhaba maalesef sizden bir ses çıkmayınca sizin için hazırladığım ve bana lazım olmayan dosyaları silmişim. Birinci dosya işinizi görüyorsa onunla idare edin. Ben o dosyaların içeriklerini bile hatırlamıyorum. Üzgünüm. Saygılar sunuyorum.

 

[ÖmerFaruk]

Aşağıdaki kodu bir deneyin.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim hcr As Range, Sh As Worksheet, Sayfam As String
    If Intersect(Target, Range("B2:B5")) Is Nothing Then Exit Sub
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Sayfam = ActiveSheet.Name
    On Error GoTo Hata
        For Each hcr In Selection
            If hcr <> "" Then
                For Each Sh In Worksheets
                    If Sh.Name = hcr.Value Then GoTo Devam
                Next Sh
                Sheets.Add After:=Worksheets(Worksheets.Count)
                HatalıAd = ActiveSheet.Name
                ActiveSheet.Name = hcr.Value
            End If
    GoTo Devam
Hata:
        Worksheets(ActiveSheet.Name).Delete
Devam:
        Next hcr
        Worksheets(Sayfam).Activate
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub

 

[yyhy]

Sayın @ÖmerFaruk bey çok teşekkür ederim.

 

[yyhy]

Teşekkürler Sayın @ÖmerFaruk ve @vurkan bey. Teşekkür ederim.