Joker karakterler ile sayfalarda arama ve o sayfaya atlama

[Mertsan]

Merhaba dostlar,

Elimde 200'ün üzerinde sayfa olan bir Excel dökümanı var. Sayfalar arasında atlama ve istenilen sayfaya gitmek için çeşitli yöntemler kullanılmış sitede paylaşılan konularda. Bir başka yabancı kaynakta aşağıdaki gibi bir kod bulup kullanabilmiştim. Bu kodu makro ayarlarında CTRL+b (bul) tuşuna atayarak CTRL+F gibi bir işlevle istediğimi sayfaya atlamak için kullanabiliyorum.

Ancak çok sayıda sayfa olunca sayfa adlarını tam bilmeden pratik olarak sayfa bulmak zorlaşıyor. Burada istediğim joker karakteri kullanarak istediğimiz isimdeki sayfaları bulacak bir ekleme yapmak.

Sayfa ismi "ANKA METAL" ise aramada sadece ANK* yazarak veya *NKA* yazarak istenilen sayfayı bulmasını sağlamak.

Bu kodlar ile mümkünse yardımınızı rica ediyorum.
iyi çalışmalar dilerim.

Sub GotoSheet()
    Dim sSheet As String

    sSheet = InputBox(Prompt:="Sayfa adı veya sayfa indeks numarasını giriniz?", Title:="Input Sheet")
    On Error Resume Next
    If Val(sSheet) > 0 Then
        Worksheets(Val(sSheet)).Activate
    Else
        Worksheets(sSheet).Activate
    End If
End Sub

 

[Emir Hüseyin Çoban]

. . .

İlk eşleşen sayfaya gider...

Sub kod()

Dim s As String
sor = InputBox("Sayfa İsmi Giriniz" & Chr("10") & "Örneğin: *Sayfa1*")
If sor = "" Then Exit Sub

For i = 1 To Sheets.Count
s = Sheets(i).Name
If Replace(Replace(UCase(s), "ı", "I"), "i", "İ") Like Replace(Replace(UCase(sor), "ı", "I"), "i", "İ") Then
Sheets(s).Select
say = 1
Exit Sub
End If
Next i

If say <> 1 Then MsgBox "Sayfa Bulunamadı!", vbCritical

End Sub

. . .

 

[alicimri]

Bende bir çalışma yapmaya çalıştım . Aşağıdaki ilk makroyu Bir tuşun kısa yola bağlayın.
İlk Makro ile İnput Box açılıyor. Oraya aranacak sayfanın Tam adını veya bir kısmını yazıyorsunuz. O kriterlere uygun Sayfaları içeren bir Liste kutusu açılıyor. Oradan seçim yapıyorsunuz.
Not: Küçük büyük harf duyarlı

Sub Ara()
Title = "Sayfa Bul"
Message = "Sayfa adını veya Sayfa adının bir kısmını giriniz"
MyValue = InputBox(Message, Title)
If MyValue <> "" Then
With ActiveSheet
    Set lb = .Shapes.AddFormControl(xlListBox, 100, 10, 100, 100)
    lb.Name = "liste"
    For x = 1 To Sheets.Count
    If InStr(1, Sheets(x).Name, MyValue) <> 0 Then
        lb.ControlFormat.AddItem Sheets(x).Name
        End If
    Next
End With
 ActiveSheet.Shapes("liste").OnAction = "git"
If ActiveSheet.ListBoxes("liste").ListCount = 0 Then
ActiveSheet.Shapes("liste").Delete
MsgBox "'" & MyValue & "'" & " Bulunamadı"
End If
End If
End Sub

Sub git()
eski = ActiveSheet.Name
 With ActiveSheet.ListBoxes("liste")
        For i = 1 To .ListCount
            If .Selected(i) Then Sheets(.List(i)).Activate
        Next i
    End With
Sheets(eski).Shapes("liste").Delete
End Sub

Aşağıdaki kodu da ThisWorkBook un kod sayfasına yapıştırısanız. Bir nedenle silinmeyen eski liste kutusuda silinir.

Private Sub Workbook_SheetActivate(ByVal Sh As Object)
For i = 1 To ActiveSheet.Shapes.Count
If ActiveSheet.Shapes(i).Name = "liste" Then
ActiveSheet.Shapes("liste").Delete
End If
Next
End Sub

 

[Mertsan]

Sayın Hüseyin ÇOBAN ve Sayın alicimri'ye hazırladıkları kodlar için çok teşekkür ediyorum. Her iki çözüm de çok etkin ve işime yaradı.
(Sorunum çözülmüştür.)

Hüseyin beyin çözümü sorumun direk yanıtı oldu.
alicimri beyin yanıtı daha farklı kullanım ufku verdi.

Kodların okunurluğu profesyonelliğini de yansıtıyor.

Ayrı ayrı tekrar teşekkür ediyorum. Bilgileriniz gerçek bir VBA hazinesi.