[转载]Excel中读出大写金额的函数

[转载]Excel中读出大写金额的函数
关键词： Excel    人民币    大写    金额    函数                                          

将下列函数复制到Excel中的工程模块中，可以使用：
=NounOfAmount("人民币",35103.27)
得到人民币叁万伍仟壹佰零叁元贰角柒分，使用：
=NounOfAmount("人民币",1000001.00)
得到人民币壹佰万零壹元整
NounOfAmount调用ChineseNumber来读整数部分，小数部分只能处理角分两位。大写金额的读法符合人民银行《现金支付办法》的要求。
ChineseNumber函数接收一个文本正整数参数（前面可加零），会读出正确的大写，最多可处理128位，如
=ChineseNumber("1"&REPT("0",127))，结果是“壹仟万亿兆京垓”。
该计数方法，壹仟亿再乘拾，结果是壹万亿。壹千万亿再乘拾结果为壹兆。壹千万亿兆再乘拾结果是壹京，下一个单位是垓。实际金额并不可能这么大，只是这个程序展示了递归算法如何处理上乘读数法。
具体算法是算出给定数字的最大基数单位，然后左右各分一半，再次调用读数程序，直到这个数小于5位，属于反复出现的小基数单位一级的仟佰拾时，进行万位以下读数处理。处理有零的情况有兴趣的同志自行研究。
背景资料，计数法。
中国古代的数学书上记录了三种不同的计数法，下乘、中乘、上乘。
下乘：
10万为1亿，10亿为1兆，10兆为1京。
1一
10一十
100一百
1000一千
10000一万
100000一亿
1000000一兆
10000000一京
......
中乘：
10000万为1亿，1万亿为1兆，1万兆为1京。
1一
10一十
100一百
1000一千
10000一万
100000一十万
1000000一百万
10000000一千万
100000000一亿
1000000000一十亿
10000000000一百亿
100000000000一千亿
1000000000000一兆
10000000000000一十兆
100000000000000一百兆
1000000000000000一千兆
10000000000000000一京
......
上乘：
1万万为亿，1亿亿为1兆，1兆兆为1京。
1一
10一十
100一百
1000一千
10000一万
100000一十万
1000000一百万
10000000一千万
100000000一亿
1000000000一十亿
10000000000一百亿
100000000000一千亿
1000000000000一万亿
10000000000000一十万亿
100000000000000一百万亿
1000000000000000一千万亿
10000000000000000一兆
100000000000000000一十兆
1000000000000000000一百兆
10000000000000000000一千兆
100000000000000000000一万兆
1000000000000000000000一十万兆
10000000000000000000000一百万兆
100000000000000000000000一千万兆
1000000000000000000000000一亿兆
10000000000000000000000000一拾亿兆
100000000000000000000000000一佰亿兆
1000000000000000000000000000一仟亿兆
10000000000000000000000000000一万亿兆
100000000000000000000000000000一十万亿兆
1000000000000000000000000000000一百万亿兆
10000000000000000000000000000000一千万亿兆
100000000000000000000000000000000一京
......

Option Base 0
Option Explicit

Function ChineseNumber(Number)
  ChineseNumber = ""
  Dim DigitName(9), SubBaseName(4), BaseName(4)
  DigitName(0) = "零"
  DigitName(1) = "壹"
  DigitName(2) = "贰"
  DigitName(3) = "叁"
  DigitName(4) = "肆"
  DigitName(5) = "伍"
  DigitName(6) = "陆"
  DigitName(7) = "柒"
  DigitName(8) = "捌"
  DigitName(9) = "玖"
  SubBaseName(1) = "拾"
  SubBaseName(2) = "佰"
  SubBaseName(3) = "仟"
  BaseName(0) = "万"
  BaseName(1) = "亿"
  BaseName(2) = "兆"
  BaseName(3) = "京"
  BaseName(4) = "垓"
  Dim Length, BaseLevel, Point
  Dim LeftLength, RightLength
  Dim LeftStr, RightStr
  Dim iCount, Char
  Length = Len(Number)
  If Length < 5 Then
    For iCount = 1 To Length
      Char = (Mid(Number, iCount, 1))
      If Char <> "0" Then
        Point = Length - iCount
        ChineseNumber = ChineseNumber + DigitName(Val(Char)) + SubBaseName(Point)
        If Point <> 0 Then
          If Mid(Number, iCount + 1, 1) = "0" Then
            If Right(Number, Point) <> String(Point, "0") Then
              ChineseNumber = ChineseNumber + DigitName(0)
            End If
          End If
        End If
      End If
    Next
  Else
    BaseLevel = Int(Log(Int((Length - 1) / 4)) / Log(2))
    RightLength = 2 ^ BaseLevel * 4
    LeftLength = Length - RightLength
    LeftStr = ChineseNumber(Left(Number, LeftLength))
    RightStr = ChineseNumber(Right(Number, RightLength))
    If LeftStr <> "" Then
      ChineseNumber = ChineseNumber + LeftStr + BaseName(BaseLevel)
      If (Mid(Number, LeftLength + 1, 1) = "0" Or Mid(Number, LeftLength, 1) = "0") And RightStr <> "" Then
        ChineseNumber = ChineseNumber + DigitName(0)
      End If
    End If
    ChineseNumber = ChineseNumber + RightStr
  End If
End Function
Function NounOfAmount(Curren, Amount)
  Dim t, r, t2, lname(10)
  lname(0) = ""
  lname(1) = "壹"
  lname(2) = "贰"
  lname(3) = "叁"
  lname(4) = "肆"
  lname(5) = "伍"
  lname(6) = "陆"
  lname(7) = "柒"
  lname(8) = "捌"
  lname(9) = "玖"
  lname(10) = "拾"
  r = ""
  If Amount = 0 Then
    NounOfAmount = "零元整"
  Else
    t = Trim(Str(Amount * 100))
    r = Curren + ChineseNumber(Left(t, Len(t) - 2))
    t2 = Right(t, 2)
    If t2 = "00" Then
      r = r + "元整"
    Else
      r = r + "元"
      If Left(t2, 1) = "0" Then
        r = r + "零" + lname(Val(Right(t2, 1))) + "分"
      ElseIf Right(t2, 1) = "0" Then
        r = r + lname(Val(Left(t2, 1))) + "角"
      Else
        r = r + lname(Val(Left(t2, 1))) + "角" + lname(Val(Right(t2, 1))) + "分"
      End If
    End If
    NounOfAmount = r
  End If
End Function