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

Question

我正在练习一些VBA代码，我正在尝试编写一个代码，它将在一个消息框中显示出不同类型的座位位置的合适价格，这些位置都有他们指定的价格。我还想确保对这段代码使用If语句。

座位位置：

方框75美元

展馆30美元

草坪$21

到目前为止，我拥有的是一个输入框，它要求用户输入座位位置，并且一个消息框会给出指定的价格。我的问题是，当用户无意中拼错了座位位置时，如何显示合适的价格。如果所有的拼写都是正确的，那么我现在拥有的代码可以工作，但是即使用户拼错了座位位置ex，我如何使它工作。他们没有进入展馆，而是进入了展馆。

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

    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

不如你只依赖于答案的第一个字母，如下所示：

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 2

取决于您想要的内容，一种选择是通过添加其他“拼写变体”来扩展if语句

or strSeat = "pavillion"

对陈述的看法。当然，更好的做法是提供一个列表框，列出唯一正确的选项。

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可能。