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?
 
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)

For me, it does trap the ESC key .

Here is the entire correct code:

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
    Private Declare PtrSafe Function SetTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
    Private Declare PtrSafe Function KillTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As Long

#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
    Private Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
    Private Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long

#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

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.
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?
No problem, if you can resolve the issue why not.
 
Upvote 0
Hi Jaafar and Mike,

When I try to run the Test sub procedure as you have typed I get a sub or function not defined message.

Mike, with yours, the equal sign has been removed but the exclamation mark is still there and it prevents me from proceeding
 
Upvote 0
Hi Jaafar and Mike,

When I try to run the Test sub procedure as you have typed I get a sub or function not defined message.

Where in the code do you get that error ? And are we talking about the code in post #9 ?
 
Upvote 0
Where in the code do you get that error ? And are we talking about the code in post #9 ?
Yep I did a straight copy and paste of post 9. It doesn't allow me to go beyond the Sub Test line.

When I try and execute the other code in your post, Excel comes up with a message to say it's going to close and then it promptly does so.
 
Upvote 0
Yep I did a straight copy and paste of post 9. It doesn't allow me to go beyond the Sub Test line.

When I try and execute the other code in your post, Excel comes up with a message to say it's going to close and then it promptly does so.

Sorry what do you mean by " It doesn't allow me to go beyond the Sub Test line" ? Do you get an error ? what does exactly heppen ?
 
Upvote 0
I just tried it again, the message this time was Microsoft Excel is trying to recover your information and then it closes all files in Excel.
 
Upvote 0
I just tried it again, the message this time was Microsoft Excel is trying to recover your information and then it closes all files in Excel.

Maybe the problem is version related ... I'll upload a workbook demo later on for you to try .
 
Upvote 0
For me, it does trap the ESC key .

Here is the entire correct code:

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
    Private Declare PtrSafe Function SetTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
    Private Declare PtrSafe Function KillTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As Long

#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
    Private Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
    Private Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long

#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


Beautiful, just beautiful.
I went back to the start and created a new workbook from scratch with your code.
I ran it and it worked perfectly. It gave me the expected messages and also worked for Esc in the Popup and Esc and Cancel in the Listbox.
Then my big challenge, incorporate my code into yours to get it to copy sheets in the way I want.
It couldn't be as simple as replace the message box with my code, surely? With a couple of extra variable declarations, yes, yes it was.
Thanks a million for your help on this. I had been looking for this for some time.

Stay safe in these troubled times.
 
Upvote 0
One question I forgot.
Why will screenupdating not work in the Sub SelectSheet()?
It gives a variable not defined error.
No biggie, but I usually include this if there's a lot going on in the background.
 
Upvote 0

Forum statistics

Threads
1,215,039
Messages
6,122,802
Members
449,095
Latest member
m_smith_solihull

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