函数实现帐本计数及大写金额（方法二则）

tanhong

一、实现金额大写，解决单元格特殊格式中＂中文大写数字＂实现数字的大写，无法转换成为金额的元角分的问题．
二、实现仿帐面计数格式（见下图）


实例下载：

方法二在六楼下载

[ 本帖最后由 tanhong 于 2008-3-19 16:17 编辑 ]

刘青梅

好例子, 学习！！

joyark

谢谢 楼主 的分享

wudi886

rrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrr

yjh16_mail

好例子, 学习！！

sfs777

收了！！！！！！！！！！！！

tanhong

我也再凑个函数:
Public Function HZtoALB(strHZ As String) As Double
    Dim strTemp As String
    Dim lngPosition As Long
    Dim lngYi As Long
    Dim lngW As Long
    Dim lngQ As Long
    Dim lngB As Long
    Dim lngS As Long
    Dim lngY As Long
    Dim sngJ As Single
    Dim sngF As Single
    '截取亿部份
    lngPosition = InStr(1, strHZ, "亿")
    If Not IsNull(lngPosition) And Not lngPosition = 0 Then
       strTemp = Mid(strHZ, 1, lngPosition - 1)
       lngYi = JQ(strTemp) * 100000000
       strHZ = Right(strHZ, Len(strHZ) - lngPosition)
    End If
    '截取万部份
    lngPosition = InStr(1, strHZ, "万")
    If Not IsNull(lngPosition) And Not lngPosition = 0 Then
       strTemp = Mid(strHZ, 1, lngPosition - 1)
        lngW = JQ(strTemp) * 10000
       strHZ = Right(strHZ, Len(strHZ) - lngPosition)
    End If
    '截取仟部份
    lngPosition = InStr(1, strHZ, "仟")
    If Not IsNull(lngPosition) And Not lngPosition = 0 Then
       strTemp = Mid(strHZ, 1, lngPosition - 1)
        lngQ = JQ(strTemp) * 1000
       strHZ = Right(strHZ, Len(strHZ) - lngPosition)
    End If
    '截取佰部份
    lngPosition = InStr(1, strHZ, "佰")
    If Not IsNull(lngPosition) And Not lngPosition = 0 Then
       strTemp = Mid(strHZ, 1, lngPosition - 1)
        lngB = JQ(strTemp) * 100
       strHZ = Right(strHZ, Len(strHZ) - lngPosition)
    End If
    '截取拾部份
    lngPosition = InStr(1, strHZ, "拾")
    If Not IsNull(lngPosition) And Not lngPosition = 0 Then
       strTemp = Mid(strHZ, 1, lngPosition - 1)
        lngS = JQ(strTemp) * 10
       strHZ = Right(strHZ, Len(strHZ) - lngPosition)
    End If
    '截取元部份
    lngPosition = InStr(1, strHZ, "元")
    If Not IsNull(lngPosition) And Not lngPosition = 0 Then
       strTemp = Mid(strHZ, 1, lngPosition - 1)
        lngY = JQ(strTemp) * 1
       strHZ = Right(strHZ, Len(strHZ) - lngPosition)
    End If
    '截取角部份
    lngPosition = InStr(1, strHZ, "角")
    If Not IsNull(lngPosition) And Not lngPosition = 0 Then
       strTemp = Mid(strHZ, 1, lngPosition - 1)
        sngJ = JQ(strTemp) * 0.1
       strHZ = Right(strHZ, Len(strHZ) - lngPosition)
    End If
    '截取分部份
    lngPosition = InStr(1, strHZ, "分")
    If Not IsNull(lngPosition) And Not lngPosition = 0 Then
       strTemp = Mid(strHZ, 1, lngPosition - 1)
        sngF = JQ(strTemp) * 0.01
       strHZ = Right(strHZ, Len(strHZ) - lngPosition)
    End If
   HZtoALB = lngYi + lngW + lngQ + lngB + lngS + lngY + sngJ + sngF
End Function
'计算每一段数值
Public Function JQ(strZ As String) As String
    Dim lngPosition As Long
    Dim strTemp As String
    Dim lngTemp As Long
    lngPosition = InStr(1, strZ, "仟")
    If Not IsNull(lngPosition) And Not lngPosition = 0 Then
       strTemp = Mid(strZ, lngPosition - 1, 1)
       lngTemp = GetArabia(strTemp) * 1000
    End If
    lngPosition = InStr(1, strZ, "佰")
    If Not IsNull(lngPosition) And Not lngPosition = 0 Then
       strTemp = Mid(strZ, (lngPosition - 1), 1)
       lngTemp = lngTemp + GetArabia(strTemp) * 100
    End If
    lngPosition = InStr(1, strZ, "拾")
    If Not IsNull(lngPosition) And Not lngPosition = 0 Then
       strTemp = Mid(strZ, lngPosition - 1, 1)
       lngTemp = lngTemp + GetArabia(strTemp) * 10
    End If
   strTemp = Right(strZ, 1)
   lngTemp = lngTemp + GetArabia(strTemp) * 1
    JQ = lngTemp
End Function

'转换汉字数字为阿拉伯数字
Public Function GetArabia(strZ As String) As Long
    Select Case strZ
        Case "壹"
           GetArabia = 1
        Case "贰"
           GetArabia = 2
        Case "叁"
           GetArabia = 3
        Case "肆"
           GetArabia = 4
        Case "伍"
           GetArabia = 5
        Case "陆"
           GetArabia = 6
        Case "柒"
           GetArabia = 7
        Case "捌"
           GetArabia = 8
        Case "玖"
           GetArabia = 9
        Case "零"
           GetArabia = 0
    End Select
End Function

pureshadow

再分享两个自定义函数（不是我写的）：
Function NtoC(n)  'n as single
Const cNum = "零壹贰叁肆伍陆柒捌玖-万仟佰拾亿仟佰拾万仟佰拾元角分"
Const cCha = "零仟零佰零拾零零零零零亿零万零元亿万零角零分零整-零零零零零亿万元亿零整整"
  NtoC = ""
  sNum = Trim(Str(Int(n * 100)))
  For I = 1 To Len(sNum) '逐位转换
    NtoC = NtoC + Mid(cNum, (Mid(sNum, I, 1)) + 1, 1) + Mid(cNum, 26 - Len(sNum) + I, 1)
  Next
  For I = 0 To 11 '去掉多余的零
    NtoC = Replace(NtoC, Mid(cCha, I * 2 + 1, 2), Mid(cCha, I + 26, 1))
  Next
End Function

Public Function BigNum(小写数字 As Double)   '将数字转为中文大写金额（本函数根据网络上的代码改编）
Application.Volatile
    If 小写数字 = 0 Then
        BigNum = "零元整"
    Else
        Const cNum = "零壹贰叁肆伍陆柒捌玖-万仟佰拾亿仟佰拾万仟佰拾元角分"
        Const cCha = "零仟零佰零拾零零零零零亿零万零元亿万零角零分零整-零零零零零亿万元亿零整整"
        BigNum = ""
        sNum = Round(Abs(小写数字), 2) * 100
        For I = 1 To Len(sNum) '逐位转换
            BigNum = BigNum + Mid(cNum, (Mid(sNum, I, 1)) + 1, 1) + Mid(cNum, 26 - Len(sNum) + I, 1)
        Next
        For I = 0 To 11 '去掉多余的零
            BigNum = Replace(BigNum, Mid(cCha, I * 2 + 1, 2), Mid(cCha, I + 26, 1))
        Next
        If 小写数字 < 0 Then
            BigNum = "负" & BigNum
        End If
    End If
End Function

tanhong

小妖提示对，我还少了四舍五入，小妖给出了一个更简便的方法(见如下公式)：

="人民币:"&NUMBERSTRING(ROUNDDOWN(C3,0),2)&"元"&NUMBERSTRING(ROUNDDOWN(MOD(C3*100,100)/10,0),2)&"角"&NUMBERSTRING(MOD(C3*100,10),2)&"分"

pureshadow

还有，再输入2.329试试