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

Inhoud

Excel versies

Deze bug is van toepassing op alle Excel versies vanaf Excel 5/95. De bug is gerepareerd in Excel 2007.

Inleiding

Dit artikel beschrijft een bug die door Ron de Bruin is ontdekt.

De Application.InputBox functie is zeer handig om een bereik door de gebruiker te laten selecteren, waarmee vervolgens in de VBA code verder gewerkt kan worden. Helaas bevat deze functie een bug (alle huidige Excel versies t/m 2003 hebben deze bug). Wanneer er op het werkblad waarop een bereik wordt geselecteerd voorwaardelijke opmaak is ingesteld waarbij bovendien gebruik is gemaakt van de optie "formule is", dan kan de functie een lege string als resultaat teruggeven, ondanks dat een geldig bereik geselecteerd was en de gebruiker gewoon op OK heeft geklikt.

De bug reproduceren

Gebruik deze voorbeeld code op een werkblad met cellen met voorwaardelijke opmaak, waarbij de "Formule Is" optie is gebruikt (zie de download hieronder voor een voorbeeld bestand):

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

Wanneer deze code wordt uitgevoerd op een dergelijk werkblad, dan blijft het Range object "oRangeSelected" leeg. Een voorbeeld formule voor de voorwaardelijke opmaak zou kunnen zijn:

=OF($A1=1; $A1=3)

Tot zover zijn er twee methodes gevonden om hier omheen te werken.

Methode 1: Gebruik een userform

Ik heb een userform gemaakt met twee controls: Een keuzelijst om het bestand te kiezen en een refedit control.

Merk op dat het refedit control wat problemen kan veroorzaken bij sommige gebruikers, ten gevolge van updates van Microsoft Office. De beste methode om deze problemen tegen te gaaan is om het bestand in Excel 2000 te openen en weer op te slaan, voordat u het bestand verspreid.

Het formulier ziet er als volgt uit:

Userform om een bereik mee te selecteren

Selecteer een bereik met hulp van een userform

De code waarmee het formulier wordt getoond:

'-------------------------------------------------------------------------
' 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

De code bij het Userform:

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

Method 2: gebruik toch Application.InputBox

De tweede methode was een suggestie door Peter Thornton (Ook een Excel MVP).

Hierbij wordt toch Application.InputBox gebruikt, echter met type 0 in plaats van 8 en een hulp routine om het juiste bereik uit de invoer te halen. Het grappige is, dat ondanks dat type 0 wordt gebruikt, u gewoon cellen kunt selecteren en het celadres dan wel doorgegeven wordt.

De celverwijzing die wordt terug gegeven door de functie behoeft wat bewerking voordat VBA het als een valide celverwijzing accepteerd. Daarom is het geheel in een functie vervat, die bovendien de gebruiker de mogelijkheid geeft opnieuw te beginnen, mocht deze bij manuele invoer een tikfout hebben gemaakt.

De code die e.e.a. mogleijk maakt is hieronder weergegeven:

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' 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

Beide methoden worden in deze download gedemonstreerd.


Vragen, suggesties en opmerkingen

Laatste 8 commentaren van in totaal 9 (Toon ze allemaal):

 


Commentaar van: Jan Karel Pieterse (29-4-2015 07:43:10) deeplink naar dit commentaar

Hallo Alain,

Ik zou gegevensvalidate (op de tab "Gegevens") gebruiken en instellen op tijd. Tevens op het tweede tabje van het validatievenster een duidelijk bericht invoeren, zodat dat aan de gebruiker wordt getoond.


Commentaar van: alain Jamine (29-4-2015 17:23:11) deeplink naar dit commentaar

alvast bedankt voor de reply, maar hier kan men nog steeds de tijd ingeven als bv 08:00 wat juist niet zo mogen. de tijdsregistratie zou enkel met de combinatietoets Ctrl + : moeten gebeuren zodat men zich niet kan vergissen of misbruik maken.
grtz Alain


Commentaar van: Jan Karel Pieterse (29-4-2015 17:53:09) deeplink naar dit commentaar

Hoi Alain,

Je zou de aangepaste optie kunnen nemen met een formule als validatie regel, waarbij je insteld dat de waarde in de cel moet liggen tussen 1 minuut voor nu en 1 minuut na nu. In het engels krijg je dan deze formule (voor cel C3):

=ABS(NOW()-INT(NOW())-C3)<1/24/60


Commentaar van: alain Jamine (29-4-2015 18:14:16) deeplink naar dit commentaar


Hoi Jan Karel,

wanneer ik de formule in de aangepaste optie plaats krijg ik de melding"er is geen bereik gevonden met de naam die u hebt opgegeven". Moet ik deze dan nog ergens aanpassen?


Commentaar van: Jan Karel Pieterse (29-4-2015 18:57:05) deeplink naar dit commentaar

Hallo Alain,

Je hebt kennelijk niet de Engelse versie van Excel :-)
Gebruik dan deze formule:

=ABS(NU()-INTEGER(NU())-C3)<1/24/60


Commentaar van: alain Jamine (29-4-2015 19:56:42) deeplink naar dit commentaar

Hoi Jan Karel,

Het werkt, bedankt. Hier heb ik reeds lang op gewacht zodat ik mijn bestand kan afwerken. Weer al iets bijgeleerd.

MVG Alain


Commentaar van: alain Jamine (2-5-2015 18:37:02) deeplink naar dit commentaar

Hoi Jan Karel,

zoals reeds eerder aangegeven werkt de formule perfect, maar mag ik je vragen wat de betekenis is van <1/24/60£; heeft het soms te maken met uren, minuten?

mvg Alain


Commentaar van: Jan Karel Pieterse (2-5-2015 21:03:08) deeplink naar dit commentaar

Hoi Alain,

Klopt. In Excel is een dag geiljk aan het getal 1, dus 1 uur 1/24 en 1 minuut 1/24/60.


Heeft u vragen, suggesties of opmerkingen? Gebruik dan dit formulier.

Mocht uw vraag niet direct relevant zijn voor deze pagina, maar een algemene Excel vraag betreffen, dan adviseer ik om deze hier te stellen: excelexperts.nl/forum/index.php.




Als u VBA code in uw commentaar plaatst, gebruik dan [VB] tags: [VB]Uw code[/VB].