Een bereik laten selecteren door de gebruiker (VBA, Bug in Application.InputBox functie)

Option Explicit

Sub ProblemCode()
    Dim oRangeSelected As Range
    On Error Resume Next
    Set oRangeSelected = Application.InputBox("Please select a range of cells!", _
                                              "SelectARAnge Demo", Selection.Address, , , , , 8)
    If oRangeSelected Is Nothing Then
        MsgBox "It appears as if you pressed cancel!"
    Else
        MsgBox "You selected: " & oRangeSelected.Address(External:=True)
    End If
End Sub

'-------------------------------------------------------------------------
' Module    : modWorkaround1
' Company   : JKP Application Development Services (c)
' Author    : Jan Karel Pieterse (jkp-ads.com)
' Created   : 23-2-2009
' Purpose   : Workaround for the application.inputbox (type 8) bug
'-------------------------------------------------------------------------
Option Explicit

Sub Test()
    Dim oRangeSelected As Range
    If SelectARange("Please select a range of cells!", "SelectARAnge Demo", oRangeSelected) = True Then
        MsgBox "You selected:" & oRangeSelected.Address(, , , True)
    Else
        MsgBox "You cancelled"
    End If
End Sub

Function SelectARange(sPrompt As String, sCaption As String, oReturnedRange As Range) As Boolean
    Dim frmSelectCells As ufSelectCells
    Set frmSelectCells = New ufSelectCells
    With frmSelectCells
        .PromptText = sPrompt
        .CaptionText = sCaption
        If TypeName(Selection) = "Range" Then
            .StartAddress = Selection.Address(External:=True)
        End If
        .Initialise
        .Show
        If .OK Then
            Set oReturnedRange = .ReturnedRange
            If oReturnedRange Is Nothing Then
                SelectARange = False
            Else
                SelectARange = True
            End If
        Else
            SelectARange = False
        End If
    End With
    Unload frmSelectCells
    Set frmSelectCells = Nothing
End Function

Option Explicit

Private mbOK As Boolean
Private moReturnedRange As Range
Private msPromptText As String
Private msCaptionText As String
Private msStartAddress As String

Public Sub Initialise()
    Dim oBk As Workbook
    cmbOK.Enabled = False
    lblQuestion.Caption = msPromptText
    Me.Caption = CaptionText
    refSelectCells.Text = StartAddress
    cbxWorkbooks.Clear
    For Each oBk In Workbooks
        If oBk.Windows(1).Visible Then
            cbxWorkbooks.AddItem oBk.Name
        End If
    Next
    cbxWorkbooks.Value = ActiveWorkbook.Name
End Sub

Private Sub cbxWorkbooks_Change()
    Windows(cbxWorkbooks.Value).Activate
End Sub

Private Sub cmbCancel_Click()
    OK = False
    Me.Hide
End Sub

Private Sub cmbOK_Click()
    If refSelectCells.Text <> "" Then
        If TypeName(Selection) = "Range" Then
            If IsValidRef(refSelectCells.Text) Then
                OK = True
            End If
        End If
    End If
    Me.Hide
End Sub

Public Property Get OK() As Boolean
    OK = mbOK
End Property

Public Property Let OK(ByVal bOK As Boolean)
    mbOK = bOK
End Property

Public Property Get ReturnedRange() As Range
    Dim sRef As String
    Dim oSh As Worksheet
    On Error Resume Next
    sRef = refSelectCells.Text
    If OK And IsValidRef(sRef) Then
        If InStr(sRef, "!") Then
            Set oSh = ActiveWorkbook.Worksheets(Application.Substitute(Left(sRef, InStr(sRef, "!") - 1), "'", ""))
        Else
            Set oSh = ActiveSheet
        End If
        Set moReturnedRange = oSh.Range(Mid(sRef, InStr(sRef, "!") + 1))
        Set ReturnedRange = moReturnedRange
    End If
End Property

Public Property Set ReturnedRange(oReturnedRange As Range)
    Set moReturnedRange = oReturnedRange
End Property

Public Function IsValidRef(sRef As String) As Boolean
'-------------------------------------------------------------------------
' Procedure : IsValidRef Created by Jan Karel Pieterse
' Company   : JKP Application Development Services (c) 2005
' Author    : Jan Karel Pieterse
' Created   : 21-12-2005
' Purpose   : Checks of argument is a valid cell reference
'-------------------------------------------------------------------------
    Dim sTemp As String
    Dim oSh As Worksheet
    Dim oCell As Range
'    On Error GoTo LocErr
    IsValidRef = False
    On Error Resume Next
    sTemp = Left(sRef, InStr(sRef, "!") - 1)
    sTemp = Replace(sTemp, "=", "")
    If Not IsIn(ActiveWorkbook.Worksheets, sTemp) Then
        IsValidRef = False
        Exit Function
    End If
    Set oSh = ActiveWorkbook.Worksheets(sTemp)
    If oSh Is Nothing Then
        Set oSh = ActiveWorkbook.Worksheets(Replace(sTemp, "'", ""))
    End If
    sTemp = Right(sRef, Len(sRef) - InStr(sRef, "!"))
    Set oCell = oSh.Range(sTemp)
    If oCell Is Nothing Then
        IsValidRef = False
    Else
        IsValidRef = True
    End If
End Function

Function IsIn(vCollection As Variant, ByVal sName As String) As Boolean
'-------------------------------------------------------------------------
' Procedure : funIsIn Created by Jan Karel Pieterse
' Company   : JKP Application Development Services (c) 2005
' Author    : Jan Karel Pieterse
' Created   : 28-12-2005
' Purpose   : Determines if object is in collection
'-------------------------------------------------------------------------
    Dim oObj As Object
    On Error Resume Next
    Set oObj = vCollection(sName)
    If oObj Is Nothing Then
        IsIn = False
    Else
        IsIn = True
    End If
    If IsIn = False Then
        sName = Replace(sName, "'", "")
        Set oObj = vCollection(sName)
        If oObj Is Nothing Then
            IsIn = False
        Else
            IsIn = True
        End If
    End If
End Function

Public Property Let PromptText(ByVal sPromptText As String)
    msPromptText = sPromptText
End Property

Private Sub refSelectCells_Change()
    If IsValidRef(refSelectCells.Text) Then
        cmbOK.Enabled = True
    Else
        cmbOK.Enabled = False
    End If
End Sub

Public Property Get CaptionText() As String
    CaptionText = msCaptionText
End Property

Public Property Let CaptionText(ByVal sCaptionText As String)
    msCaptionText = sCaptionText
End Property


Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    If CloseMode <> vbFormCode Then
        Cancel = True
        Me.cmbCancel.SetFocus
        cmbCancel_Click
    End If
End Sub

Public Property Get StartAddress() As String
    msStartAddress = Mid(msStartAddress, InStr(msStartAddress, "]") + 1)
    StartAddress = msStartAddress
End Property

Public Property Let StartAddress(sStartAddress As String)
    msStartAddress = sStartAddress
End Property

Option Explicit
'Courtesy Peter Thornton (Excel MVP)

Sub TestGetInput()
    Dim bGotRng As Boolean
    Dim bActivate As Boolean
    Dim rInput As Range
    bActivate = False   ' True to re-activate the input range
    bGotRng = GetInputRange(rInput, "Please select a range of cells!", _
                            "SelectARAnge Demo", "", bActivate)
    If bGotRng Then
        MsgBox rInput.Address(External:=True)
    Else
        MsgBox "You pressed cancel"
    End If
End Sub

Function GetInputRange(rInput As Excel.Range, _
                       sPrompt As String, _
                       sTitle As String, _
                       Optional ByVal sDefault As String, _
                       Optional ByVal bActivate As Boolean, _
                       Optional X, Optional Y) As Boolean
' rInput:    The Input Range which returns to the caller procedure
' bActivate: If True user's input range will be re-activated
'
' The other arguments are standard InputBox arguments.
' sPrompt & sTitle should be supplied from the caller proccedure
' but sDefault will be completed below if empty
'
' GetInputRange returns True if rInput is successfully assigned to a Range

    Dim bGotRng As Boolean
    Dim bEvents As Boolean
    Dim nAttempt As Long
    Dim sAddr As String
    Dim vReturn

    On Error Resume Next
    If Len(sDefault) = 0 Then
        If TypeName(Application.Selection) = "Range" Then
            sDefault = "=" & Application.Selection.Address
            ' InputBox cannot handle address/formulas over 255
            If Len(sDefault) > 240 Then
                sDefault = "=" & Application.ActiveCell.Address
            End If
        ElseIf TypeName(Application.ActiveSheet) = "Chart" Then
            sDefault = " first select a Worksheet"
        Else
            sDefault = " Select Cell(s) or type address"
        End If
    End If
    Set rInput = Nothing    ' start with a clean slate
    For nAttempt = 1 To 3  ' give user 3 attempts for typos
        vReturn = False
        vReturn = Application.InputBox(sPrompt, sTitle, sDefault, X, Y, Type:=0)
        If False = vReturn Or Len(vReturn) = 0 Then
            Exit For    ' user cancelled
        Else
            sAddr = vReturn
            ' The address (or formula) could be in A1 or R1C1 style,
            ' w/out an "=" and w/out embracing quotes, depends if the user
            ' selected cells, typed an address, or accepted the default
            If Left$(sAddr, 1) = "=" Then sAddr = Mid$(sAddr, 2, 256)
            If Left$(sAddr, 1) = Chr(34) Then sAddr = Mid$(sAddr, 2, 255)
            If Right$(sAddr, 1) = Chr(34) Then sAddr = Left$(sAddr, Len(sAddr) - 1)
            '  will fail if R1C1 address
            Set rInput = Application.Range(sAddr)
            If rInput Is Nothing Then
                sAddr = Application.ConvertFormula(sAddr, xlR1C1, xlA1)
                Set rInput = Application.Range(sAddr)
                bGotRng = Not rInput Is Nothing
            Else
                bGotRng = True
            End If
        End If

        If bGotRng Then
            If bActivate Then   ' optionally re-activate the Input range
                On Error GoTo errH
                bEvents = Application.EnableEvents
                Application.EnableEvents = False
                If Not Application.ActiveWorkbook Is rInput.Parent.Parent Then
                    rInput.Parent.Parent.Activate    ' Workbook
                End If
                If Not Application.ActiveSheet Is rInput.Parent Then
                    rInput.Parent.Activate    ' Worksheet
                End If
                rInput.Select    ' Range
            End If
            Exit For
        ElseIf nAttempt < 3 Then
            ' Failed to get a valid range, maybe a typo
            If MsgBox("Invalid reference, do you want to try again ?", _
                      vbOKCancel, sTitle) <> vbOK Then
                Exit For
            End If
        End If
    Next    ' nAttempt
cleanUp:
    On Error Resume Next
    If bEvents Then
        Application.EnableEvents = True
    End If
    GetInputRange = bGotRng
    Exit Function
errH:
    Set rInput = Nothing
    bGotRng = False
    Resume cleanUp
End Function