VBA输入框和If语句 - 捕获用户拼写错误

Question

我正在练习一些VBA代码，而我正在尝试编写一个代码，该代码将在消息框中显示具有指定价​​格的各种类型的座位位置的相应价格。我还想确保为此代码使用If语句。

座位位置：

Box $ 75

Pavilion $ 30

草坪21美元

到目前为止，我所要求的是一个输入框，要求用户输入座位位置，并在消息框中显示指定的价格。我的问题是弄清楚当用户无意中拼错座位位置时如何显示适当的价格。如果所有内容拼写正确，我现在可以使用的代码，但即使用户拼错了座位位置ex，我该如何使其工作。而不是Pavilion，他们进入Pavillion。

这是我到目前为止的代码。

    Option Explicit
    Public Sub ConcertPricing()
    'declare variables
    Dim strSeat As String
    Dim curTicketPrice As Currency

    'ask user for desired seat location
    strSeat = InputBox("Enter seat location", "Seat Location")
   'if statement that assigns appropriate pricing according to seat selection
   If strSeat = "Box" Then
    curTicketPrice = 75
    Else
       If strSeat = "Pavilion" Then
       curTicketPrice = 30
       Else
          If strSeat = "Lawn" Then
          curTicketPrice = 21
          Else
             If strSeat = "Other" Then
             curTicketPrice = 0
             End If
          End If
       End If
    End If

    'pricing results based on seat selection
    MsgBox ("The ticket price for a seat in the " & strSeat & " location is:    " & Format(curTicketPrice, "$0.00"))

    End Sub

谢谢！

Answer 1

取决于您想要的，一个选项是通过添加

来扩展您的if语句以及其他“拼写变体”

USE [E:\SANDWICH3\ABC\BIN\DEBUG\DATABASE\ABC.MDF]
GO

DECLARE @return_value Int

EXEC    @return_value = [dbo].[SPmainReport]
    @startDate = '2015-12-25',
    @endDate = '2015-12-25',
    @customerName = N'John'

SELECT  @return_value as 'Return Value'

GO

声明。更好的方法是提供一个列表框，当然只有正确的选项。

Answer 2

你怎么能仅仅依赖于答案的第一个字母：

Option Explicit
Option Compare Text

Public Sub ConcertPricing()
'declare variables
Dim strSeat As String
Dim curTicketPrice As Currency

'ask user for desired seat location
strSeat = InputBox("Enter seat location", "Seat Location")
'if statement that assigns appropriate pricing according to seat selection
Select Case LCase(Left(Trim(strSeat), 1))
Case "b"
    curTicketPrice = 75
Case "p"
    curTicketPrice = 30
Case "l"
    curTicketPrice = 21
Case "o"
    curTicketPrice = 0
Case Else
    MsgBox "The location you entered cannot be recognised." & Chr(10) & "Assuming 'Other' as location...."
    curTicketPrice = 0
End Select

'pricing results based on seat selection
MsgBox ("The ticket price for a seat in the " & strSeat & " location is:    " & Format(curTicketPrice, "$0.00"))

End Sub

正如您所看到的，用户只需要获得正确答案的第一个字母，甚至不需要关心大写或小写。

Answer 3

这样的事情就是你真正想要的：

Public Function stringSimilarity(str1 As String, str2 As String) As Variant
'Simple version of the algorithm that computes the similiarity metric
'between two strings.
'NOTE: This verision is not efficient to use if you're comparing one string
'with a range of other values as it will needlessly calculate the pairs for the
'first string over an over again; use the array-optimized version for this case.

    Dim sPairs1 As Collection
    Dim sPairs2 As Collection

    Set sPairs1 = New Collection
    Set sPairs2 = New Collection

    WordLetterPairs str1, sPairs1
    WordLetterPairs str2, sPairs2

    stringSimilarity = SimilarityMetric(sPairs1, sPairs2)

    Set sPairs1 = Nothing
    Set sPairs2 = Nothing

End Function

Public Function strSimA(str1 As Variant, rRng As Range) As Variant
'Return an array of string similarity indexes for str1 vs every string in input range rRng
    Dim sPairs1 As Collection
    Dim sPairs2 As Collection
    Dim arrOut As Variant
    Dim l As Long, j As Long

    Set sPairs1 = New Collection

    WordLetterPairs CStr(str1), sPairs1

    l = rRng.Count
    ReDim arrOut(1 To l)
    For j = 1 To l
        Set sPairs2 = New Collection
        WordLetterPairs CStr(rRng(j)), sPairs2
        arrOut(j) = SimilarityMetric(sPairs1, sPairs2)
        Set sPairs2 = Nothing
    Next j

    strSimA = Application.Transpose(arrOut)

End Function

Public Function strSimLookup(str1 As Variant, rRng As Range, Optional returnType) As Variant
'Return either the best match or the index of the best match
'depending on returnTYype parameter) between str1 and strings in rRng)
' returnType = 0 or omitted: returns the best matching string
' returnType = 1           : returns the index of the best matching string
' returnType = 2           : returns the similarity metric

    Dim sPairs1 As Collection
    Dim sPairs2 As Collection
    Dim metric, bestMetric As Double
    Dim i, iBest As Long
    Const RETURN_STRING As Integer = 0
    Const RETURN_INDEX As Integer = 1
    Const RETURN_METRIC As Integer = 2

    If IsMissing(returnType) Then returnType = RETURN_STRING

    Set sPairs1 = New Collection

    WordLetterPairs CStr(str1), sPairs1

    bestMetric = -1
    iBest = -1

    For i = 1 To rRng.Count
        Set sPairs2 = New Collection
        WordLetterPairs CStr(rRng(i)), sPairs2
        metric = SimilarityMetric(sPairs1, sPairs2)
        If metric > bestMetric Then
            bestMetric = metric
            iBest = i
        End If
        Set sPairs2 = Nothing
    Next i

    If iBest = -1 Then
        strSimLookup = CVErr(xlErrValue)
        Exit Function
    End If

    Select Case returnType
    Case RETURN_STRING
        strSimLookup = CStr(rRng(iBest))
    Case RETURN_INDEX
        strSimLookup = iBest
    Case Else
        strSimLookup = bestMetric
    End Select

End Function

Public Function strSim(str1 As String, str2 As String) As Variant
    Dim ilen, iLen1, ilen2 As Integer

    iLen1 = Len(str1)
    ilen2 = Len(str2)

    If iLen1 >= ilen2 Then ilen = ilen2 Else ilen = iLen1

    strSim = stringSimilarity(Left(str1, ilen), Left(str2, ilen))

End Function

Sub WordLetterPairs(str As String, pairColl As Collection)
'Tokenize str into words, then add all letter pairs to pairColl

    Dim Words() As String
    Dim word, nPairs, pair As Integer

    Words = Split(str)

    If UBound(Words) < 0 Then
        Set pairColl = Nothing
        Exit Sub
    End If

    For word = 0 To UBound(Words)
        nPairs = Len(Words(word)) - 1
        If nPairs > 0 Then
            For pair = 1 To nPairs
                pairColl.Add Mid(Words(word), pair, 2)
            Next pair
        End If
    Next word

End Sub

Private Function SimilarityMetric(sPairs1 As Collection, sPairs2 As Collection) As Variant
'Helper function to calculate similarity metric given two collections of letter pairs.
'This function is designed to allow the pair collections to be set up separately as needed.
'NOTE: sPairs2 collection will be altered as pairs are removed; copy the collection
'if this is not the desired behavior.
'Also assumes that collections will be deallocated somewhere else

    Dim Intersect As Double
    Dim Union As Double
    Dim i, j As Long

    If sPairs1.Count = 0 Or sPairs2.Count = 0 Then
        SimilarityMetric = CVErr(xlErrNA)
        Exit Function
    End If

    Union = sPairs1.Count + sPairs2.Count
    Intersect = 0

    For i = 1 To sPairs1.Count
        For j = 1 To sPairs2.Count
            If StrComp(sPairs1(i), sPairs2(j)) = 0 Then
                Intersect = Intersect + 1
                sPairs2.Remove j
                Exit For
            End If
        Next j
    Next i

    SimilarityMetric = (2 * Intersect) / Union

End Function

使用它像：

If stringSimilarity(strSeat, "Box") >= 0.8
    'do stuff
End If

例如，

stringSimilarity("Vox", "Box") = 0.5
stringSimilarity("Boxx", "Box") = 0.8
stringSimilarity("Pavilion", "Pavillion") = 0.93
stringSimilarity("Box", "Pavillion") = 0

你可以获得更多的创意，并将strSeat与所有可能性进行比较，如果它高于你的确定性评级，则可以采用最高的一个，例如0.5。