VBA 输入框和 If 语句 - 捕捉用户拼写错误
VBA Input Box and If Statement - Catching user misspellings
我正在练习一些 VBA 代码，我正在尝试编写一个代码，该代码将在消息框中为具有指定价格的各种类型的座位位置显示适当的价格。我还想确保我对这段代码使用了 If 语句。
座位位置：
一箱 75 美元
展馆 $30
草坪 $21
到目前为止，我有一个输入框，要求用户输入座位位置，然后会出现一个消息框，显示指定的价格。我的问题是弄清楚当用户无意中拼错座位位置时如何显示合适的价格。如果一切都拼写正确，我现在拥有的代码可以工作，但是即使用户拼错了座位位置，我如何才能使它工作。他们没有进入 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, "[=11=].00"))
End Sub
谢谢！
取决于您的需要，一种选择是通过添加
来使用额外的 'spelling variations' 扩展您的 if 语句
or strSeat = "pavillion"
声明。更好的办法是提供一个列表框，当然只有正确的选项。
你让它仅仅依赖于答案的第一个字母怎么样：
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, "[=10=].00"))
End Sub
如你所见，用户只需要把答案的首字母写对即可，根本不需要关心大小写。
这样的东西才是你真正想要的：
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。
我正在练习一些 VBA 代码，我正在尝试编写一个代码，该代码将在消息框中为具有指定价格的各种类型的座位位置显示适当的价格。我还想确保我对这段代码使用了 If 语句。
座位位置：
一箱 75 美元
展馆 $30
草坪 $21
到目前为止，我有一个输入框，要求用户输入座位位置，然后会出现一个消息框，显示指定的价格。我的问题是弄清楚当用户无意中拼错座位位置时如何显示合适的价格。如果一切都拼写正确，我现在拥有的代码可以工作，但是即使用户拼错了座位位置，我如何才能使它工作。他们没有进入 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, "[=11=].00"))
End Sub
谢谢！
取决于您的需要，一种选择是通过添加
来使用额外的 'spelling variations' 扩展您的 if 语句or strSeat = "pavillion"
声明。更好的办法是提供一个列表框，当然只有正确的选项。
你让它仅仅依赖于答案的第一个字母怎么样：
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, "[=10=].00"))
End Sub
如你所见，用户只需要把答案的首字母写对即可，根本不需要关心大小写。
这样的东西才是你真正想要的：
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。