Input box select sheet

Tigerexcel

Board Regular
Joined
Mar 6, 2020
Messages
210
Office Version
2016
Platform
Windows
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?
 

Some videos you may like

Excel Facts

How to calculate loan payments in Excel?
Use the PMT function: =PMT(5%/12,60,-25000) is for a $25,000 loan, 5% annual interest, 60 month loan.

dmt32

Well-known Member
Joined
Jul 3, 2012
Messages
5,674
Office Version
2019
Platform
Windows
Hi,
try following code as an alternative to using InputBox Method

VBA Code:
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

Board Regular
Joined
Mar 6, 2020
Messages
210
Office Version
2016
Platform
Windows
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

Well-known Member
Joined
Jul 3, 2012
Messages
5,674
Office Version
2019
Platform
Windows
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

Board Regular
Joined
Mar 6, 2020
Messages
210
Office Version
2016
Platform
Windows
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

Well-known Member
Joined
Jul 3, 2012
Messages
5,674
Office Version
2019
Platform
Windows
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

Board Regular
Joined
Mar 6, 2020
Messages
210
Office Version
2016
Platform
Windows
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

Well-known Member
Joined
Dec 5, 2002
Messages
7,758
Office Version
2016
Platform
Windows
Alternatively, you could use some API trick to achieve this .

In a standard Module ( run the Test routine)
VBA Code:
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

Well-known Member
Joined
Dec 5, 2002
Messages
7,758
Office Version
2016
Platform
Windows
Ignore the previous code and use the one below which removes the ugly-looking text selection in the InputBox.

VBA Code:
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

Board Regular
Joined
Mar 6, 2020
Messages
210
Office Version
2016
Platform
Windows
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
 

Watch MrExcel Video

Forum statistics

Threads
1,095,267
Messages
5,443,436
Members
405,235
Latest member
1Thess521

This Week's Hot Topics

Top