Input box select sheet

[Tigerexcel]

I'm trying to insert an input box whereby the user just selects a worksheet, rather than having to type it in.
So far I have,

Dim Sheetname As String

If ActiveWorkbook Is Nothing Then Exit Sub


Sheetname = Application.InputBox("Where is the source data?")

Sheets(Sheetname).Select


When you select the worksheet, it will write it in with exclamation mark eg =Attendance!, the macro then returns an error message asking me to check my formulae, so it is a range issue.
However if I simply type Attendance in the input box, it works fine., if I select =Attendance! and remove the equal sign and the exclamation mark, it works fine. How can I amend the code so that the user simply just clicks onto the required worksheet?

 

[dmt32]

Hi,
try following code as an alternative to using InputBox Method

Sub SelectSheet()
    Dim ws As Worksheet

    If ActiveWorkbook.Sheets.Count <= 16 Then
        Application.CommandBars("Workbook Tabs").ShowPopup 500, 225
    Else
        Application.CommandBars("Workbook Tabs").Controls("More Sheets...").Execute
    End If
    
    Set ws = Worksheets(ActiveSheet.Name)
    
    'do other stuff
    
    
End Sub

Code will display a popup menu of all sheets in the workbook - selecting a sheet from the menu will activate the sheet

Dave

 

[Tigerexcel]

The previous post (ie my post, not Dave's which came in just as I was typing this one) isn't as clear as I wanted it to be . The objective of the macro is to select a worksheet from a workbook. The issue is if you select any worksheet other than the active worksheet the inputbox returns the sheet reference with an = sign and an exclamation mark so if one of the sheets is named Attendance it will register as =Attendance! in the input box and the resulting macro will return an error message where it asks me to check my formula. If I remove the = and the ! sign the macro will work.
Is there a way to remove the = and the ! characters?

 

[dmt32]

I understood your question but do not have an answer using the Application.InputBox Method in manner you require which is why I offered an alternative solution.

Dave

 

[Tigerexcel]

Thanks Dave, your suggestion worked well.
I was wondering why I hadn't had any replies and have been scouring the internet to see if the extraneous sheet references could be removed. Guess that the input boxes are too problematic. Is there a way to add an instruction to your code such as Please select the source file/if ticked file is the source file, press Enter

 

[dmt32]

Whilst not fully sure, I think the error prompt you are getting with inputbox is a builtin feature but another here may have a more definitive answer.

I claim no originality for code posted - Its stock code i have used in the distant past

You could as suggestion, add msgbox prompts at appropriate places in your project to guide your users

Dave

 

[Tigerexcel]

Whilst not fully sure, I think the error prompt you are getting with inputbox is a builtin feature but another here may have a more definitive answer.

I claim no originality for code posted - Its stock code i have used in the distant past

You could as suggestion, add msgbox prompts at appropriate places in your project to guide your users

Dave

Thanks Dave for your solution, it fits the bill and will really help.
I like input boxes and in this case it lets you set a default worksheet which means the user just has to press enter without any extra keystrokes and the macro will run. Shame I couldn't get around this particular limitation, if anyone else knows a workaround it would be good to know.

 

[Jaafar Tribak]

Alternatively, you could use some API trick to achieve this .

In a standard Module ( run the Test routine)

Option Explicit

#If VBA7 Then
    Declare PtrSafe Function SetTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
    Declare PtrSafe Function KillTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
    Declare PtrSafe Function GetDlgItem Lib "user32" (ByVal hDlg As LongPtr, ByVal nIDDlgItem As Long) As LongPtr
    Declare PtrSafe Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As LongPtr, ByVal lpString As String, ByVal cch As Long) As Long
    Declare PtrSafe Function SetWindowText Lib "user32" Alias "SetWindowTextA" (ByVal hwnd As LongPtr, ByVal lpString As String) As Long
    Declare PtrSafe Function GetForegroundWindow Lib "user32" () As LongPtr
#Else
    Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
    Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
    Declare Function GetDlgItem Lib "user32" (ByVal hDlg As Long, ByVal nIDDlgItem As Long) As Long
    Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
    Declare Function SetWindowText Lib "user32" Alias "SetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String) As Long
    Declare Function GetForegroundWindow Lib "user32" () As Long
#End If



Sub Test()

    Dim sSheetName As String
    
    Application.DisplayAlerts = False
    
    EnableSheetSelection = True
        sSheetName = Application.InputBox("Where is the source data?")
    EnableSheetSelection = False
    
    If Len(sSheetName) And sSheetName <> "False" Then
        If SheetExists(sSheetName) Then
            Sheets(sSheetName).Select
        Else
            Debug.Print "Invalid Sheet."
        End If
    End If

End Sub



Private Sub AdjustSheetName()

    #If VBA7 Then
        Dim hwnd As LongPtr
    #Else
        Dim hwnd As Long
    #End If

    Dim sBuff As String * 256, lRet As Long
    Dim sSheetName As String

    On Error GoTo ErrHandler
    hwnd = GetDlgItem(GetForegroundWindow, &H13)
    lRet = GetWindowText(hwnd, sBuff, 256)
    sSheetName = Left(sBuff, lRet)
    If Len(sSheetName) And SheetExists(sSheetName) = False Then
        sSheetName = Mid(sSheetName, InStr(1, sSheetName, "+", vbTextCompare) + 1, Len(sSheetName))
        sSheetName = Replace(Replace(Replace(sSheetName, "=", ""), "!", ""), "'", "")
        SetWindowText hwnd, sSheetName
    End If
    Exit Sub
    
ErrHandler:
    KillTimer Application.hwnd, 0

End Sub


Private Function SheetExists(ByVal SheetName As String) As Boolean
    Dim sh As Worksheet
    On Error Resume Next
    Set sh = Sheets(SheetName)
    SheetExists = Not (sh Is Nothing)
End Function


Private Property Let EnableSheetSelection(ByVal Enable As Boolean)
    If Enable Then
        SetTimer Application.hwnd, 0, 0, AddressOf AdjustSheetName
    Else
        KillTimer Application.hwnd, 0
    End If
End Property

 

[Jaafar Tribak]

Ignore the previous code and use the one below which removes the ugly-looking text selection in the InputBox.

Option Explicit

#If VBA7 Then
    Declare PtrSafe Function SetTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
    Declare PtrSafe Function KillTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
    Declare PtrSafe Function GetDlgItem Lib "user32" (ByVal hDlg As LongPtr, ByVal nIDDlgItem As Long) As LongPtr
    Declare PtrSafe Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As LongPtr, ByVal lpString As String, ByVal cch As Long) As Long
    Declare PtrSafe Function SetWindowText Lib "user32" Alias "SetWindowTextA" (ByVal hwnd As LongPtr, ByVal lpString As String) As Long
    Declare PtrSafe Function GetForegroundWindow Lib "user32" () As LongPtr
    Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr
#Else
    Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
    Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
    Declare Function GetDlgItem Lib "user32" (ByVal hDlg As Long, ByVal nIDDlgItem As Long) As Long
    Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
    Declare Function SetWindowText Lib "user32" Alias "SetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String) As Long
    Declare Function GetForegroundWindow Lib "user32" () As Long
    Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
#End If



Sub Test()

    Dim sSheetName As String
   
    Application.DisplayAlerts = False
   
    EnableSheetSelection = True
        sSheetName = Application.InputBox("Where is the source data?")
    EnableSheetSelection = False
   
    If Len(sSheetName) And sSheetName <> "False" Then
        If SheetExists(sSheetName) Then
            Sheets(sSheetName).Select
        Else
            Debug.Print "Invalid Sheet."
        End If
    End If

End Sub



Private Sub AdjustSheetName()

    Const EM_SETSEL = &HB1
   
    #If VBA7 Then
        Dim hwnd As LongPtr
    #Else
        Dim hwnd As Long
    #End If

    Dim sBuff As String * 256, lRet As Long
    Dim sSheetName As String

    On Error GoTo ErrHandler
    hwnd = GetDlgItem(GetForegroundWindow, &H13)
    lRet = GetWindowText(hwnd, sBuff, 256)
    sSheetName = Left(sBuff, lRet)
    If Len(sSheetName) And SheetExists(sSheetName) = False Then
        sSheetName = Mid(sSheetName, InStr(1, sSheetName, "+", vbTextCompare) + 1, Len(sSheetName))
        sSheetName = Replace(Replace(Replace(sSheetName, "=", ""), "!", ""), "'", "")
        SetWindowText hwnd, sSheetName
        Call SendMessage(hwnd, EM_SETSEL, ByVal CLng(Len(sSheetName)), ByVal CLng(Len(sSheetName)))
    End If
    Exit Sub
   
ErrHandler:
    KillTimer Application.hwnd, 0

End Sub


Private Function SheetExists(ByVal SheetName As String) As Boolean
    Dim sh As Worksheet
    On Error Resume Next
    Set sh = Sheets(SheetName)
    SheetExists = Not (sh Is Nothing)
End Function


Private Property Let EnableSheetSelection(ByVal Enable As Boolean)
    If Enable Then
        SetTimer Application.hwnd, 0, 0, AddressOf AdjustSheetName
    Else
        KillTimer Application.hwnd, 0
    End If
End Property

 

[Tigerexcel]

Hi Jaafar,

I tried to run the Test subprocedure and the Adjust Sheet name procedure and Excel just crashed.
Just to be clear, the one that I should be running is:

Private Sub AdjustSheetName()

Const EM_SETSEL = &HB1

#If VBA7 Then
Dim hwnd As LongPtr
#Else
Dim hwnd As Long
#End If

Dim sBuff As String * 256, lRet As Long
Dim sSheetName As String

On Error GoTo ErrHandler
hwnd = GetDlgItem(GetForegroundWindow, &H13)
lRet = GetWindowText(hwnd, sBuff, 256)
sSheetName = Left(sBuff, lRet)
If Len(sSheetName) And SheetExists(sSheetName) = False Then
sSheetName = Mid(sSheetName, InStr(1, sSheetName, "+", vbTextCompare) + 1, Len(sSheetName))
sSheetName = Replace(Replace(Replace(sSheetName, "=", ""), "!", ""), "'", "")
SetWindowText hwnd, sSheetName
Call SendMessage(hwnd, EM_SETSEL, ByVal CLng(Len(sSheetName)), ByVal CLng(Len(sSheetName)))
End If
Exit Sub

ErrHandler:
KillTimer Application.hwnd, 0

End Sub