修复Excel VBA SpellNum_Dollar函数仅转换数字前半段问题

我看到你遇到的问题了——原来的SpellNum_Dollar函数只转换了数字的高位部分，漏掉了低位分段。这个问题的核心原因是Dollars变量的拼接逻辑错误，代码里用了未初始化的空变量D，导致每次循环都覆盖了之前的转换结果，而不是累加所有分段的文本。

下面是修正后的完整代码，我标记了关键的修改点：

Option Explicit
'Main Function
Function SpellNum_Dollar(ByVal MyNumber As Variant) As String
    Dim Dollars, Cents, Temp
    Dim DecimalPlace, Count
    ReDim Place(9) As String
    Place(2) = " Thousand "
    Place(3) = " Million "
    Place(4) = " Billion "
    Place(5) = " Trillion "
    ' String representation of amount.
    MyNumber = Trim(Str(MyNumber))
    ' Position of decimal place 0 if none.
    DecimalPlace = InStr(MyNumber, ".")
    ' Convert Cents and set MyNumber to dollars amount.
    If DecimalPlace > 0 Then
        Cents = GetTens(Left(Mid(MyNumber, DecimalPlace + 1) & _
                "00", 2))
        MyNumber = Trim(Left(MyNumber, DecimalPlace - 1))
    End If
    Count = 1
    Do While MyNumber <> ""
        Temp = GetHundreds(Right(MyNumber, 3))
        If Temp <> "" Then 
            ' 修正：将新转换的高位文本追加到现有Dollars前，移除无用的D变量
            Dollars = Temp & Place(Count) & Dollars 
        End If
        If Len(MyNumber) > 3 Then
            MyNumber = Left(MyNumber, Len(MyNumber) - 3)
        Else
            MyNumber = ""
        End If
        Count = Count + 1
    Loop
    Select Case Dollars
        Case ""
            Dollars = "No Dollars"
        Case "One"
            Dollars = "One Dollar only"
        Case Else
            Dollars = Dollars & " Dollars only" ' 补充only，匹配你的示例需求
    End Select
    Select Case Cents
        Case ""
            Cents = ""
        Case "One"
            Cents = " and One Cent"
        Case Else
            Cents = " and " & Cents & " Cents"
    End Select
    SpellNum_Dollar = LowerCaseWords(Dollars & Cents)
End Function
' Converts a number from 100-999 into text
Function GetHundreds(ByVal MyNumber)
    Dim Result As String
    If Val(MyNumber) = 0 Then Exit Function
    MyNumber = Right("000" & MyNumber, 3)
    ' Convert the hundreds place.
    If Mid(MyNumber, 1, 1) <> "0" Then
        Result = GetDigit(Mid(MyNumber, 1, 1)) & " Hundred "
    End If
    ' Convert the tens and ones place.
    If Mid(MyNumber, 2, 1) <> "0" Then
        Result = Result & GetTens(Mid(MyNumber, 2))
    Else
        Result = Result & GetDigit(Mid(MyNumber, 3))
    End If
    GetHundreds = Result
End Function
' Converts a number from 10 to 99 into text.
Function GetTens(TensText)
    Dim Result As String
    Result = "" ' Null out the temporary function value.
    If Val(Left(TensText, 1)) = 1 Then ' If value between 10-19...
        Select Case Val(TensText)
            Case 10: Result = "Ten"
            Case 11: Result = "Eleven"
            Case 12: Result = "Twelve"
            Case 13: Result = "Thirteen"
            Case 14: Result = "Fourteen"
            Case 15: Result = "Fifteen"
            Case 16: Result = "Sixteen"
            Case 17: Result = "Seventeen"
            Case 18: Result = "Eighteen"
            Case 19: Result = "Nineteen"
            Case Else
        End Select
    Else ' If value between 20-99...
        Select Case Val(Left(TensText, 1))
            Case 2: Result = "Twenty-"
            Case 3: Result = "Thirty-"
            Case 4: Result = "Forty-"
            Case 5: Result = "Fifty-"
            Case 6: Result = "Sixty-"
            Case 7: Result = "Seventy-"
            Case 8: Result = "Eighty-"
            Case 9: Result = "Ninety-"
            Case Else
        End Select
        Result = Result & GetDigit _
            (Right(TensText, 1)) ' Retrieve ones place.
    End If
    If Right(Result, 1) = "-" Then
        Result = Left(Result, Len(Result) - 1)
    End If
    GetTens = Result
End Function
' Converts a number from 1 to 9 into text.
Function GetDigit(Digit)
    Select Case Val(Digit)
        Case 1: GetDigit = "One"
        Case 2: GetDigit = "Two"
        Case 3: GetDigit = "Three"
        Case 4: GetDigit = "Four"
        Case 5: GetDigit = "Five"
        Case 6: GetDigit = "Six"
        Case 7: GetDigit = "Seven"
        Case 8: GetDigit = "Eight"
        Case 9: GetDigit = "Nine"
        Case Else: GetDigit = ""
    End Select
End Function
Function LowerCaseWords(MyNumber As String) As String
    'Splits the number into an array and then loops through the array, starting at the second word, and lower cases all of them
    'Just need to check if the first word has a dash, if so, the first letter after the dash will be lower cased
    Const ArrayLoopStart As Long = 1
    Dim WordArray As Variant
    Dim WordCounter As Long
    Dim FindDash As Long
    WordArray = Split(MyNumber, " ")
    FindDash = InStr(1, WordArray(0), "-")
    If FindDash > 0 Then
        WordArray(0) = Left(WordArray(0), FindDash) & LCase(Mid(WordArray(0), FindDash + 1, 1)) & Right(WordArray(0), Len(WordArray(0)) - 1 - FindDash)
    End If
    For WordCounter = ArrayLoopStart To UBound(WordArray)
        WordArray(WordCounter) = LCase(WordArray(WordCounter))
    Next WordCounter
    LowerCaseWords = Join(WordArray, " ")
End Function

关键修改说明： #

1. 修复Dollars拼接逻辑：将原代码中的Dollars = Temp & Place(Count) & D改为Dollars = Temp & Place(Count) & Dollars，这样每次处理的高位数字文本会追加到现有结果的前面，实现完整的分段累加（比如先处理323得到"Three hundred twenty-three"，再处理284得到"Two hundred eighty-four Thousand "，拼接后就是"Two hundred eighty-four Thousand Three hundred twenty-three"）。
2. 移除无用变量D：原代码中声明了D但从未赋值和正确使用，直接删除即可。
3. 补充"only"后缀：在Dollars的分支中添加了 only，匹配你示例中期望的结果格式。

测试示例： #

• 输入284323.00，输出：Two hundred eighty-four thousand three hundred twenty-three dollars only
• 输入877666.00，输出：Eight hundred seventy-seven thousand six hundred sixty-six dollars only

内容的提问来源于stack exchange，提问作者Obada Kurdi