Excel

Question

ismine göre bir sayfa bulun Bu bir çözüm kadar çok bir soru değil, ama burada ihtiyaç duyduğum şeyler için yardım aldığım için burada paylaşmak istedim.

Belirli bir Excel sayfasını, Etkin Çalışma Kitabında, sayfanın adına göre arama yapmak istedim. Bunu bulmak için yaptım. Bu bir "içerir" aramadır ve bulunursa otomatik olarak sayfaya gider veya birden çok eşleşme olup olmadığını kullanıcıya sorar:

Herhangi bir zamanda sona erdirmek için, giriş kutusuna bir boşluk girin.

 
Public Sub Find_Tab_Search() 
    Dim sSearch As String 
    sSearch = "" 
    sSearch = InputBox("Enter Search", "Find Tab") 
    If Trim(sSearch) = "" Then Exit Sub 
    'MsgBox (sSearch) 

    Dim sSheets() As String 
    Dim sMatchMessage As String 
    Dim iWorksheets As Integer 
    Dim iCounter As Integer 
    Dim iMatches As Integer 
    Dim iMatch As Integer 
    Dim sGet As String 
    Dim sPrompt As String 

    iMatch = -1 
    iMatches = 0 
    sMatchMessage = "" 

    iWorksheets = Application.ActiveWorkbook.Sheets.Count 
    ReDim sSheets(iWorksheets) 

    'Put list of names in array 
    For iCounter = 1 To iWorksheets 
     sSheets(iCounter) = Application.ActiveWorkbook.Sheets(iCounter).Name 
     If InStr(1, sSheets(iCounter), sSearch, vbTextCompare) > 0 Then 
      iMatches = iMatches + 1 
      If iMatch = -1 Then iMatch = iCounter 
      sMatchMessage = sMatchMessage + CStr(iCounter) + ": " + sSheets(iCounter) + vbCrLf 
     End If 
    Next iCounter 

    Select Case iMatches 
     Case 0 
      'No Matches 
      MsgBox "No Match Found for " + sSearch 
     Case 1 
      '1 match activate the sheet 
      Application.ActiveWorkbook.Sheets(iMatch).Activate 
     Case Else 
      'More than 1 match. Ask them which sheet to go to 
      sGet = -1 
      sPrompt = "More than one match found. Please enter number from following list" 
      sPrompt = sPrompt + "to display the sheet" + vbCrLf + vbCrLf + sMatchMessage 
      sPrompt = sPrompt + vbCrLf + vbCrLf + "Enter blank to cancel" 
      sGet = InputBox(sPrompt, "Please select one") 
      If Trim(sGet) = "" Then Exit Sub 
      sPrompt = "Value must be a number" + vbCrLf + vbCrLf + sPrompt 
      Do While IsNumeric(sGet) = False 
       sGet = InputBox(sPrompt, "Please select one") 
       If Trim(sGet) = "" Then Exit Sub 
      Loop 
      iMatch = CInt(sGet) 
      Application.ActiveWorkbook.Sheets(iMatch).Activate 
    End Select 

End Sub 

Umarım birisi bunu yararlı bulur ve geliştirme önerilerini de memnuniyetle karşılar. Eğlence için

Answer 1

Aralık adı, xlm kullanır döngüler ile mümkün olduğunca az hatlarında bunu denedik ve VBS yukarıdaki gibi aynı çok levha arama işlevleri sağlamak Filter kullanılan altında. kod

yığın bellek taşması tabaka seçimi kısmı

Sub GetNAmes() 
Dim strIn As String 
Dim X 

strIn = Application.InputBox("Search string", "Enter string to find", ActiveSheet.Name, , , , , 2) 
If strIn = "False" Then Exit Sub 

ActiveWorkbook.Names.Add "shtNames", "=RIGHT(GET.WORKBOOK(1),LEN(GET.WORKBOOK(1))-FIND(""]"",GET.WORKBOOK(1)))" 
X = Filter([index(shtNames,)], strIn, True, 1) 

Select Case UBound(X) 
    Case Is > 0 
     strIn = Application.InputBox(Join(X, Chr(10)), "Multiple matches found - type position to select", , , , , 1) 
     If strIn = "False" Then Exit Sub 
     On Error Resume Next 
     Sheets(CStr(X(strIn))).Activate 
     On Error GoTo 0 
    Case 0 
     Sheets(X(0)).Activate 
    Case Else 
     MsgBox "No match" 
End Select 

End Sub