Office中国论坛/Access中国论坛

标题: 函数实现帐本计数及大写金额（方法二则） [打印本页]
作者: tanhong    时间: 2008-3-19 11:27
标题: 函数实现帐本计数及大写金额（方法二则）
一、实现金额大写，解决单元格特殊格式中＂中文大写数字＂实现数字的大写，无法转换成为金额的元角分的问题．
二、实现仿帐面计数格式（见下图）
[attach]28988[/attach]

实例下载：[attach]28989[/attach]

方法二在六楼下载

[ 本帖最后由 tanhong 于 2008-3-19 16:17 编辑 ]
作者: tmtony    时间: 2008-3-19 11:43
又有好例子, 学习学习!!
作者: pureshadow    时间: 2008-3-19 13:30
嘿嘿......试用过隐藏函数吗,公式可以短很多哟......
用NUMBERSTRING
先不公布
江版动脑筋自己做一个
作者: huangqinyong    时间: 2008-3-19 13:56
江版出新品
作者: tanhong    时间: 2008-3-19 14:44
原帖由 pureshadow 于 2008-3-19 13:30 发表
嘿嘿......试用过隐藏函数吗,公式可以短很多哟......
用NUMBERSTRING
先不公布
江版动脑筋自己做一个


哈哈!小妖卖关子.考我哦
好,我做一个,下午教卷
作者: tanhong    时间: 2008-3-19 15:44
小妖完成你下达的任务．用隐藏函数做的，实现金额大写函数，不知道是不是符合要求，你有什么更好的办法，帖出来哦．
下面是我写的函数．
=IF(ISERR(SEARCH(".",C3))=FALSE,NUMBERSTRING(INT(C3),2)&"元" &IF(LEN(C3)-SEARCH(".",C3)=1,NUMBERSTRING(RIGHT(C3,1),2) &"角整",NUMBERSTRING(LEFT(RIGHT(C3,2),1),2) &"角"& NUMBERSTRING(RIGHT(C3,1),2) &"分"),NUMBERSTRING(INT(C3),2)&"元整")

见下图：
[attach]29043[/attach]
实例二：[attach]29044[/attach]
作者: pureshadow    时间: 2008-3-19 16:23
江版输入2.392试试

作者: pureshadow    时间: 2008-3-19 16:30
还有，再输入2.329试试
作者: tanhong    时间: 2008-3-19 16:33
小妖提示对，我还少了四舍五入，小妖给出了一个更简便的方法(见如下公式)：

="人民币:"&NUMBERSTRING(ROUNDDOWN(C3,0),2)&"元"&NUMBERSTRING(ROUNDDOWN(MOD(C3*100,100)/10,0),2)&"角"&NUMBERSTRING(MOD(C3*100,10),2)&"分"
作者: pureshadow    时间: 2008-3-19 16:52
再分享两个自定义函数（不是我写的）：
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    时间: 2008-3-19 17:00
我也再凑个函数:
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, &quot;亿&quot;)
    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, &quot;万&quot;)
    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, &quot;仟&quot;)
    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, &quot;佰&quot;)
    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, &quot;拾&quot;)
    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, &quot;元&quot;)
    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, &quot;角&quot;)
    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, &quot;分&quot;)
    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, &quot;仟&quot;)
    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, &quot;佰&quot;)
    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, &quot;拾&quot;)
    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 &quot;壹&quot;
           GetArabia = 1
        Case &quot;贰&quot;
           GetArabia = 2
        Case &quot;叁&quot;
           GetArabia = 3
        Case &quot;肆&quot;
           GetArabia = 4
        Case &quot;伍&quot;
           GetArabia = 5
        Case &quot;陆&quot;
           GetArabia = 6
        Case &quot;柒&quot;
           GetArabia = 7
        Case &quot;捌&quot;
           GetArabia = 8
        Case &quot;玖&quot;
           GetArabia = 9
        Case &quot;零&quot;
           GetArabia = 0
    End Select
End Function
作者: sfs777    时间: 2008-3-19 17:02
收了！！！！！！！！！！！！
作者: yjh16_mail    时间: 2008-3-21 16:35
好例子, 学习！！
作者: wudi886    时间: 2009-5-18 09:12
rrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrr
作者: joyark    时间: 2011-7-23 02:51
谢谢 楼主 的分享
作者: 刘青梅    时间: 2016-12-4 20:54
好例子, 学习！！



欢迎光临 Office中国论坛/Access中国论坛 (http://www.office-cn.net/) Powered by Discuz! X3.3