Input box select sheet

Tigerexcel

Active Member
Joined
Mar 6, 2020
Messages
493
Office Version
  1. 365
  2. 2019
Platform
  1. 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?
 
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

I hope this doesn't count as hijacking your thread Tigerexcel but I've had this issue before myself and was never able to get a workaround for it.
I have a follow up question for dmt32, if that's ok with both of you?
This is as close as I've seen to what I want and would suit me perfectly. I'm always trying to make less work for the user.
In my case I am using this to allow the user to select a sheet to be copied.
I do have one issue. If I press Esc on either the Popup or the Listbox or Cancel on the Listbox it doesn't Exit Sub. It continues through the code which means it performs the copy.
Is there a way to trap the Esc or Cancel for the Popup and Listbox so that I can include an Exit Sub if this should happen?
 
Upvote 0

Excel Facts

Copy formula down without changing references
If you have =SUM(F2:F49) in F50; type Alt+' in F51 to copy =SUM(F2:F49) to F51, leaving the formula in edit mode. Change SUM to COUNT.
Hi Jaafar,
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:

No. it is the Test routine that you should be running.
The code works fine for me.
 
Upvote 0
Is there a way to trap the Esc or Cancel for the Popup and Listbox so that I can include an Exit Sub if this should happen?

I have only ever used that code for < 16 sheets in couple of projects so have never needed to give any thought to capturing Cancel button press - I don't have an immediate solution to your request but maybe someone has - meantime, I will have a quiet think.

Dave
 
Upvote 0
Even with a worksheet with <16 sheets if I press Esc the result is the same as the Cancel with >16 sheets.
The code continues to execute while the Esc is not caught and dealt with.
 
Upvote 0
Even with a worksheet with <16 sheets if I press Esc the result is the same as the Cancel with >16 sheets.
The code continues to execute while the Esc is not caught and dealt with.
This should handle the ESC key:
VBA Code:
Option Explicit

#If VBA7 Then
    Declare PtrSafe Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
#Else
    Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
#End If


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
    
          
   If GetAsyncKeyState(VBA.vbKeyEscape) = 0 Then
        MsgBox ws.Name
   End If

End Sub

As for handling the Cancel or X button of the popup window, it can be done but with a bit more involved code that subclasses the popup
 
Upvote 0
Try

VBA Code:
Dim ChosenSheet as Worksheet

If ActiveWorkbook Is Nothing Then Exit Sub

On Error Resume Next
Set ChosenSheet = Application.InputBox("Where is the source data?", type:=8).Parent
On Error Goto 0

If ChosenSheet Is Nothing Then Exit Sub

ChosenSheet.Select
 
Upvote 0
Even with a worksheet with <16 sheets if I press Esc the result is the same as the Cancel with >16 sheets.
The code continues to execute while the Esc is not caught and dealt with.


Ok here is something that worked for me... I have wrapped the calls to :
Application.CommandBars("Workbook Tabs").ShowPopup
and
Application.CommandBars("Workbook Tabs").Controls("More Sheets...").Execute

inside a single custom routine named : ShowSheetsPopUp

This should handle the ESC key as well as the X close and Cancel buttons of the PopUp


In a Standard Module:
VBA Code:
Option Explicit

Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0 To 7) As Byte
End Type

#If VBA7 Then
    Private Declare PtrSafe Function DispCallFunc Lib "oleAut32.dll" (ByVal pvInstance As LongPtr, ByVal offsetinVft As LongPtr, ByVal CallConv As Long, ByVal retTYP As Integer, ByVal paCNT As Long, ByRef paTypes As Integer, ByRef paValues As LongPtr, ByRef retVAR As Variant) As Long
    Private Declare PtrSafe Function StringFromGUID2 Lib "ole32" (ByRef rguid As GUID, ByVal lpsz As LongPtr, ByVal cchMax As Long) As Long
    Private Declare PtrSafe Function CLSIDFromString Lib "ole32" (ByVal OleStringCLSID As LongPtr, ByRef cGUID As GUID) As Long
    Private Declare PtrSafe Function CoCreateInstance Lib "ole32" (ByRef rclsid As GUID, ByVal pUnkOuter As LongPtr, ByVal dwClsContext As Long, ByRef riid As GUID, ByRef ppv As LongPtr) As Long
    Private Declare PtrSafe Function SysReAllocString Lib "oleAut32.dll" (ByVal pBSTR As LongPtr, Optional ByVal pszStrPtr As LongPtr) As Long
    Private Declare PtrSafe Function SetProcessDPIAware Lib "user32" () As Long
    Private Declare PtrSafe Sub SetLastError Lib "kernel32" (ByVal dwErrCode As Long)
    Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As Currency) As Long
    Private Declare PtrSafe Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
#Else
    Private Declare Function DispCallFunc Lib "oleAut32.dll" (ByVal pvInstance As Long, ByVal offsetinVft As Long, ByVal CallConv As Long, ByVal retTYP As Integer, ByVal paCNT As Long, ByRef paTypes As Integer, ByRef paValues As Long, ByRef retVAR As Variant) As Long
    Private Declare Function StringFromGUID2 Lib "ole32" (ByRef rguid As GUID, ByVal lpsz As Long, ByVal cchMax As Long) As Long
    Private Declare Function CLSIDFromString Lib "ole32" (ByVal OleStringCLSID As Long, ByRef cGUID As GUID) As Long
    Private Declare Function CoCreateInstance Lib "ole32" (ByRef rclsid As GUID, ByVal pUnkOuter As Long, ByVal dwClsContext As Long, ByRef riid As GUID, ByRef ppv As Long) As Long
    Private Declare Function SysReAllocString Lib "oleAut32.dll" (ByVal pBSTR As Long, Optional ByVal pszStrPtr As Long) As Long
    Private Declare Function SetProcessDPIAware Lib "user32" () As Long
    Private Declare Sub SetLastError Lib "kernel32" (ByVal dwErrCode As Long)
    Private Declare Function GetCursorPos Lib "user32" (lpPoint As Currency) As Long
    Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
#End If

Public bCancelled As Boolean



Sub ShowSheetsPopUp()

    On Error GoTo ErrHandler
    bCancelled = False
    SetTimer Application.hwnd, 0, 0, AddressOf MonitorMouseLeave
    If ActiveWorkbook.Sheets.Count <= 16 Then
        Application.CommandBars("Workbook Tabs").ShowPopup 500, 225
    Else
        Application.CommandBars("Workbook Tabs").Controls("More Sheets...").Execute
    End If
  
ErrHandler:
    KillTimer Application.hwnd, 0

End Sub


Private Sub MonitorMouseLeave()

    #If VBA7 Then
      #If Win64 Then
            Const PTR_FACTOR = 2
        #Else
            Const PTR_FACTOR = 1
      #End If
        Dim pAuto As LongPtr
        Dim pElement As LongPtr
        Dim pCurrentName As LongPtr
   #Else
        Const PTR_FACTOR = 1
        Dim pAuto As Long
        Dim pElement As Long
        Dim pCurrentName As Long
   #End If

    Const S_OK = 0&
    Const CLSCTX_INPROC_SERVER = &H1
    Const CC_STDCALL = 4&
    Const IUnknownRelease = 8&
    Const IID_CUIAUTOMATION = "{FF48DBA4-60EF-4201-AA87-54103EEF594E}"
    Const IID_IUIAUTOMATION = "{30CBE57D-D9D0-452A-AB13-7AC5AC4825EE}"

    Dim iidCuiAuto As GUID, iidIuiAuto As GUID, tPt As Currency
    Dim lRet As Long, VTableOffset As Long
  
    On Error Resume Next
      
    lRet = CLSIDFromString(StrPtr(IID_CUIAUTOMATION), iidCuiAuto)
    Call DispGUID(iidCuiAuto)
    lRet = CLSIDFromString(StrPtr(IID_IUIAUTOMATION), iidIuiAuto)
    Call DispGUID(iidIuiAuto)
    lRet = CoCreateInstance(iidCuiAuto, 0, CLSCTX_INPROC_SERVER, iidIuiAuto, pAuto)
  
    If lRet = S_OK Then
        Call GetCursorPos(tPt)
        VTableOffset = 28 * PTR_FACTOR
        lRet = CallFunction_COM(pAuto, VTableOffset, vbLong, CC_STDCALL, tPt, VarPtr(pElement))
        If lRet = S_OK Then
            VTableOffset = 92 * PTR_FACTOR
            lRet = CallFunction_COM(pElement, VTableOffset, vbLong, CC_STDCALL, VarPtr(pCurrentName))
            If lRet = S_OK Then
                If GetStrFromPtrW(pCurrentName) = "Cancel" Or GetStrFromPtrW(pCurrentName) = "Close" Then
                    KillTimer Application.hwnd, 0
                    bCancelled = True
                End If
                Call CallFunction_COM(pElement, IUnknownRelease, vbLong, CC_STDCALL)
            End If
            Call CallFunction_COM(pAuto, IUnknownRelease, vbLong, CC_STDCALL)
        End If
    End If

End Sub



#If VBA7 Then
    Private Function CallFunction_COM(ByVal InterfacePointer As LongPtr, ByVal VTableOffset As Long, ByVal FunctionReturnType As Long, ByVal CallConvention As Long, ParamArray FunctionParameters() As Variant) As Variant
        Dim vParamPtr() As LongPtr
#Else
    Private Function CallFunction_COM(ByVal InterfacePointer As Long, ByVal VTableOffset As Long, ByVal FunctionReturnType As Long, ByVal CallConvention As Long, ParamArray FunctionParameters() As Variant) As Variant
        Dim vParamPtr() As Long
#End If

    Dim pIndex As Long, pCount As Long
    Dim vParamType() As Integer
    Dim vRtn As Variant, vParams() As Variant

    vParams() = FunctionParameters()
    pCount = Abs(UBound(vParams) - LBound(vParams) + 1&)
    If pCount = 0& Then
        ReDim vParamPtr(0 To 0)
        ReDim vParamType(0 To 0)
    Else
        ReDim vParamPtr(0 To pCount - 1&)
        ReDim vParamType(0 To pCount - 1&)
        For pIndex = 0& To pCount - 1&
            vParamPtr(pIndex) = VarPtr(vParams(pIndex))
            vParamType(pIndex) = VarType(vParams(pIndex))
        Next
    End If

     pIndex = DispCallFunc(InterfacePointer, VTableOffset, CallConvention, FunctionReturnType, pCount, vParamType(0), vParamPtr(0), vRtn)

    If pIndex = 0& Then
        CallFunction_COM = vRtn
    Else
        SetLastError pIndex
    End If
End Function


#If VBA7 Then
    Private Function GetStrFromPtrW(ByVal Ptr As LongPtr) As String
#Else
    Private Function GetStrFromPtrW(ByVal Ptr As Long) As String
#End If

    SysReAllocString VarPtr(GetStrFromPtrW), Ptr
  
End Function


Private Sub DispGUID(objGuid As GUID)

    Dim lRet As Long
    Dim sTmp As String
    Dim buf(100) As Byte
  
    lRet = StringFromGUID2(objGuid, VarPtr(buf(0)), UBound(buf) - 1)
    sTmp = buf
  
End Sub




Code Usage :
VBA Code:
Sub SelectSheet()

    Dim ws As Worksheet
  
    Call ShowSheetsPopUp
    Set ws = Worksheets(ActiveSheet.Name)
  
    If GetAsyncKeyState(VBA.vbKeyEscape) = 0 Then
        If bCancelled = False Then
            MsgBox "You selected sheet : " & ws.Name
        Exit Sub
        End If
    End If
  
    MsgBox "You Cancelled."

End Sub
 
Upvote 0
@mikerickson
Originally I had the user type in the sheet name as I couldn't see any other way of achieving this. But it worked fine.
When I came across this today I saw a way of allowing the user to select the sheet form a list which is what I wanted.
Your code brings me back to my original inputbox again. But thanks for your contribution.

@Jaffar Tribak
I had some hope of playing around with your previous code, which I did as described below.
I can't get this to work.
The issue, as I see it, is that the check for Esc is being performed too late. The copy of the sheet has already taken place when the check has been performed.
I played around with the code a bit:
I changed the msgbox to an Exit Sub and moved it to the beginning before my code.
But when I run it now it exits every time, regardless of whether I press Esc or select a sheet from the popup.

I have no clue what your new code is doing, far too advanced for me.
But I did attempt to get it going with the following error:
On this line: SetTimer Application.Hwnd, 0, 0, AddressOf MonitorMouseLeave Error is Sub or Function not defined.
I can normally make a good attempt at chasing down the source of errors but as I say, I'm lost on this one.
 
Upvote 0
@mikerickson
I have no clue what your new code is doing, far too advanced for me.
But I did attempt to get it going with the following error:
On this line: SetTimer Application.Hwnd, 0, 0, AddressOf MonitorMouseLeave Error is Sub or Function not defined.
I can normally make a good attempt at chasing down the source of errors but as I say, I'm lost on this one.

Oops!!

I forgot to declare the SetTimer function... Simply add these declarations at the top of the first code just below Option Explicit
VBA Code:
#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
#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
#End If
 
Upvote 0
I haven't adapted it to include my own code, hopefully I can, but that does seem to work for the Cancel with the code as is.
But it still doesn't handle the Esc. Whether you select a sheet or press Esc you get the same thing, the message "You selected sheet: Oct" (or whatever sheet is selected)
 
Upvote 0

Forum statistics

Threads
1,213,536
Messages
6,114,207
Members
448,554
Latest member
Gleisner2

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top