请看图片：
答案 0 :(得分：0)
这可能比你讨价还价更多，但这可能比它更少更好。试试吧。但首先，请理解设置。这个想法是你有一个单元格 - 当然是在工作表中输入金额。然后你有另一个单元格 - 假定在同一个工作表上，但不一定如此 - 在单词中显示金额。将调用过程粘贴在工作表的代码表中，在该代码表中，单元格包含金额。
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Const AmountCell As String = "B5" ' read the amount from here
Const TargetCell As String = "D5" ' write the words here
Const Indian As Boolean = True
If Target.Address = Range(AmountCell).Address Then
Call WriteAmountInWords(Target.Value, Range(TargetCell), Indian)
End If
End Sub
此代码包含许多可以设置的参数。他们从上述程序开始。金额将写入单元格B5。您可以指定任何其他单元格。您可以添加代码以指定多个单元格。如果您想在另一张纸上执行相同的操作，则还需要将该代码的副本粘贴到该另一张纸的代码表中。
上面的代码指定要写入单元格D5的单词。您可以隐式或相对于AmountCell指定任何其他单元格。这是此处未涉及的另一项编程任务。
最后，您可以将Indian指定为True或False。如果你指定为True，你会获得十万分和一分之二。虚假将产生数百万和数十亿。如果您需要，也可以通过编程方式设置此属性。但请注意，目前的结构不适合动态变化。你必须用变量替换常量。
上面的代码调用了程序WriteAmountInWords，它需要很多支持代码。所有这一切都必须在一个新的，正常的（不是类和非形式）代码模块上。它的名字并不重要，但你可以称之为SpellNum。将所有以下代码粘贴到该模块中。
Option Explicit
Option Base 0
Enum Ncr ' Index to Array Curr()
NcrCurr
NcrOnly ' word used when there are no cents
NcrAnd ' word used between dollars and cents
NcrFraction
End Enum
Enum Nct ' CaseType
NctLower ' = all lower case
NctFirst ' = Only first character in upper case
NctProper ' = Each word's first character capitalised (Default)
NctUpper ' = all caps
End Enum
Enum Ngp ' Number groups: Powers of 1000
NgpN
NgpM ' = 1000's
NgpMM ' = millions
NgpBn ' = billions
NgpDec ' decimals
End Enum
Const SpellCurr As String = "dollar,only,and,cent"
Const Ones As String = "zero one two three four five six seven eight nine"
Const Teens As String = "teen eleven twelve thir four fif six seven eigh nine"
Const Tens As String = "null ten twenty thirty fourty fifty sixty seventy eighty ninety"
Const Powers_En As String = "hundred thousand million billion"
Const Powers_In As String = "hundred thousand lakh crore"
Dim Powers As String
Public Sub WriteAmountInWords(ByVal Amt As Variant, _
ByRef TargetCell As Range, _
ByVal Indian As Boolean)
Const WithCurr As Boolean = False
Const NoDecs As Boolean = False
Const SpellDecs As Boolean = False
Const CaseType As Long = NctProper
TargetCell.Value = SpellAmount(Amt, Indian, WithCurr, NoDecs, SpellDecs, CaseType)
End Sub
Private Function SpellAmount(ByVal Amt As Variant, _
ByVal Indian As Boolean, _
ByVal WithCurr As Boolean, _
ByVal NoDecs As Boolean, _
ByVal SpellDecs As Boolean, _
ByVal CaseType As Long) As String
' return the amount Amt in words
' include the currency, if WithCurr = True
' True to suppress zero fractions in integers,
' also ignore fractions existing in Amt
' write out fractions, if SpellDecs = True
' specify any Nct value for CaseType (Proper by default)
Dim Num As Double ' = Amt
Dim Spa As String ' result
Dim S As String ' partial result
Dim Sp() As String ' groups of numbers
Dim G As Ngp
Powers = IIf(Indian, Powers_In, Powers_En)
Num = SetGroups(Amt, Sp, Indian)
For G = NgpBn To NgpN Step -1
If Val(Sp(G)) > 0 Then
S = Spell999(Sp(G))
If G > NgpN Then
S = WithBreak(S, True) & Split(Powers)(G)
End If
Spa = WithBreak(Spa, True) & S
End If
Next G
If Len(Spa) = 0 Then Spa = Split(Ones)(0)
If NoDecs Then
If WithCurr Then Call AddCurrency(Spa, Int(Num))
Else
Call AddDecimals(Spa, Sp(NgpDec), SpellDecs, WithCurr, Num)
End If
SpellAmount = WriteProper(Spa, CaseType)
End Function
Private Function Spell999(G3 As String) As String
' return the amount in words of a G3 of 3 numbers
Dim Sp As String ' result
Dim S As String ' partial result
Dim n(1 To 3) As Integer ' value of each character
Dim IsTeen As Boolean
Dim i As Long
For i = 1 To 3
n(i) = Val(Mid(Right("000" & G3, 3), i, 1))
Next i
If n(1) > 0 Then Sp = WithBreak((Split(Ones)(n(1)))) & _
Split(Powers)(NgpN)
If n(2) = 1 And n(3) > 0 Then
IsTeen = True
ElseIf n(2) Then
Sp = WithBreak(Sp) & Split(Tens)(n(2))
End If
If n(3) Then
If IsTeen Then
S = Split(Teens)(n(3))
If n(3) > 2 Then
S = WithBreak(S) & Split(Teens)(0)
End If
Else
S = Split(Ones)(n(3))
End If
Sp = WithBreak(Sp) & S
End If
Spell999 = Sp
End Function
Private Sub AddDecimals(ByRef Spa As String, _
ByVal Decs As String, _
ByVal SpellDecs As Boolean, _
ByVal WithCurr As Boolean, _
ByVal Num As Double)
Dim S As String
If WithCurr And SpellDecs Then Call AddCurrency(S, Int(Num))
S = WithBreak(S, True) & Split(SpellCurr, ",") _
(NcrOnly - CBool(Val(Decs)))
If SpellDecs Then
If Val(Decs) Then
S = WithBreak(S, True) & Spell999(Decs)
If WithCurr Then
Call AddCurrency(S, Val(Decs), True)
Else
S = WithBreak(S, True) & Split(Powers)(0) & "th"
End If
End If
Else
S = WithBreak(S, True) & Decs & "/100"
If WithCurr Then Call AddCurrency(S, Num)
End If
Spa = WithBreak(Spa, True) & S
End Sub
Private Function SetGroups(ByVal Amt As Variant, _
ByRef Sp() As String, _
ByVal Indian As Boolean) As Double
' Sp() is a return array
Dim Grps() As Variant
Dim A As String
Dim n As Integer
Dim i As Integer
If Indian Then
Grps = Array(5, 2, 2, 3) ' from left to right
Else
Grps = Array(3, 3, 3, 3)
End If
ReDim Sp(NgpDec)
A = Format(Unformat(Amt), String(12, "0") & ".00")
For i = NgpN To (NgpDec - 1)
Sp(NgpDec - i - 1) = Mid(A, n + 1, Grps(i))
n = n + Grps(i)
Next i
Sp(NgpDec) = Right(A, 2)
SetGroups = Val(A)
End Function
Private Function Unformat(ByVal Amt As Variant) As String
Dim Uf As String
Dim S As String
Dim i As Integer
For i = 1 To Len(Amt)
S = Mid(Amt, i, 1)
If IsNumeric(S) Or S = "." Then
Uf = Uf & S
End If
Next i
Unformat = Uf
End Function
Private Function WithBreak(ByVal S As String, _
Optional ByVal AddSpace As Boolean) _
As String
' append a conditional line break or space to S
Dim BreakChar As Integer
BreakChar = IIf(AddSpace, 32, 31)
WithBreak = S
If Len(S) > 1 Then
If Asc(Right(S, 1)) <> BreakChar Then
WithBreak = S + Chr(BreakChar)
End If
End If
End Function
Private Function WriteProper(ByVal S As String, _
ByVal CaseType As Nct) As String
Dim Wp As String
Dim Sp() As String
Dim n As Long
If Len(S) Then
Wp = LCase(S)
Select Case CaseType
Case NctFirst
Wp = UCase(Left(S, 1)) & Mid(S, 2)
Case NctProper
Sp = Split(Wp)
For n = LBound(Sp) To UBound(Sp)
Sp(n) = UCase(Left(Sp(n), 1)) & Mid(Sp(n), 2)
Next n
Wp = Join(Sp)
Case NctUpper
Wp = UCase(S)
End Select
End If
WriteProper = Wp
End Function
Private Sub AddCurrency(ByRef Spa As String, _
ByVal Num As Double, _
Optional IsFraction As Boolean)
Dim S As String
Dim i As Ncr
i = IIf(IsFraction, NcrFraction, NcrCurr)
S = Split(SpellCurr, ",")(i) & IIf(Num = 1, "", "s")
Spa = WithBreak(Spa, True) & S
End Sub
查找这行代码Const SpellCurr As String = "dollar,only,and,cent"。将美元更改为您的货币名称。同样的“美分”。但是，默认情况下，将在不指定货币的情况下写入单词。您必须通过将Const WithCurr As Boolean = False更改为True来启用此功能。
此设置从书面金额中排除小数。 Const NoDecs As Boolean = False。您可以将其更改为True。一旦它为True，您就可以指定如何以单词或数字写小数。 Const SpellDecs As Boolean = False默认值为False，表示为数字，如00/100。
WriteAmountInWords程序中的最后一个常量确定拼写数量的大小写。 Const CaseType As Long = NctProper。要设置此常量，请使用代码顶部的其中一个枚举（此处重复）。
Enum Nct ' CaseType
NctLower ' = all lower case
NctFirst ' = Only first character in upper case
NctProper ' = Each word's first character capitalised (Default)
NctUpper ' = all caps
End Enum
请注意，注册名称的大小写将根据您的偏好进行调整。一旦您以不同方式对名称进行大写，VBA将记住并遵循您的指导。负责任地打字。