ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

搜索
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 效率神器,一键搞定繁琐工作
HR薪酬管理数字化实战 Excel 2021函数公式学习大典 Excel数据透视表实战秘技 打造核心竞争力的职场宝典
让更多数据处理,一键完成 数据工作者的案头书 免费直播课集锦 ExcelHome出品 - VBA代码宝免费下载
用ChatGPT与VBA一键搞定Excel WPS表格从入门到精通 Excel VBA经典代码实践指南
查看: 2584|回复: 9

[分享] 人民币中文大写转阿拉伯数字(宏)v1.00_Beta

[复制链接]

TA的精华主题

TA的得分主题

发表于 2016-9-10 07:58 | 显示全部楼层 |阅读模式
本帖最后由 413191246se 于 2016-9-12 22:22 编辑

***简介:《人民币中文大写转阿拉伯数字》宏(v1.00_Beta),由于本人水平较低,未达到完美程度,但轻量级的中文大写金额(如10亿以下)基本比较正确,现在有些10-100亿的金额尚未解决(未解决的在附件《疑难》中),最大识别金额为壹仟亿元整!***如有需要的朋友(包括徒弟139),在你的实际工作中如果数值不超过10亿元,可以应用此宏,但建议转换后务必认真校对,以确保数据完全。
***在运行本宏的过程中,请不要操作鼠标和键盘,直到程序完成。
***怎么消除转换后的重波浪线呢?很简单,只须:编辑菜单/全选/点击工具栏上的下划线按钮两次(中间要稍等一下)即可。
测试附件: demo 人民币中文大写转阿拉伯数字(测试附件).rar (10.36 KB, 下载次数: 29)
  1. Sub 人民币中文大写转阿拉伯数字()
  2.     Dim n As Long, i As String, j As String
  3.     If MsgBox("阿拉伯数字是否放在大写前面?(否则后面)", vbYesNo + vbExclamation, "人民币中文大写转阿拉伯数字") = vbYes Then n = 1 Else n = 0
  4.     ActiveDocument.Paragraphs.Last.Range.InsertAfter Text:=vbCr & "`"
  5.     Selection.HomeKey unit:=wdStory
  6.     Do
  7.         Selection.MoveRight unit:=wdCharacter, Count:=1, Extend:=wdExtend
  8.         If Selection = "`" Then Exit Do
  9.         Do While Selection.Characters.Last Like "[壹贰叁肆伍陆柒捌玖零亿万仟佰拾元圆角分整]"
  10.             Selection.MoveRight unit:=wdCharacter, Count:=1, Extend:=wdExtend
  11.             If Selection.Characters.Last Like "[!壹贰叁肆伍陆柒捌玖零亿万仟佰拾元圆角分整]" Then
  12.                 Selection.MoveEnd unit:=wdCharacter, Count:=-1

  13.                 If Len(Selection) = 1 Then Exit Do
  14.                 Do While Selection Like "[亿万仟佰元圆角分整]*"
  15.                     Selection.MoveStart unit:=wdCharacter, Count:=1
  16.                 Loop
  17.                 Do While Selection Like "*零"
  18.                     Selection.MoveEnd unit:=wdCharacter, Count:=-1
  19.                 Loop

  20.                 If Selection Like "*仟*亿*元*" And Selection <> "壹仟亿元整" Then
  21.                     Selection.Font.Color = wdColorRed '红色
  22.                     Selection.Font.Bold = True '加粗
  23.                     Selection.Font.Underline = wdUnderlineWavyHeavy '重波浪线
  24.                     GoTo Skip
  25.                 End If

  26. '                Selection.Font.Bold = True '加粗
  27. '                Selection.Font.Color = wdColorBlue '蓝色
  28.                 Selection.Font.Underline = wdUnderlineWavyHeavy '重波浪线
  29. Skip:
  30.                 i = Selection.Text
  31.                 i = Replace(i, "圆", "元")
  32.                 If i Like "*[!元角分整]" Then i = i & "元整"
  33.                 If i Like "*元" Then i = i & "整"
  34. '
  35.                 If i Like "*佰亿零?仟万*" Then i = Replace(i, "佰亿零", "00")
  36.                 If i Like "*佰亿零?佰万*" Then i = Replace(i, "佰亿零", "000")
  37.                 If i Like "*佰亿零?拾万*" Then i = Replace(i, "佰亿零", "0000")
  38.                 If i Like "*佰亿零?万*" Then i = Replace(i, "佰亿零", "00000")
  39.                 If i Like "*佰亿零?仟*" Then i = Replace(i, "佰亿零", "000000")
  40.                 If i Like "*佰亿零?佰*" Then i = Replace(i, "佰亿零", "0000000")
  41.                 If i Like "*佰亿零?拾*" Then i = Replace(i, "佰亿零", "00000000")
  42.                 If i Like "*佰亿零*" Then i = Replace(i, "佰亿零", "000000000")

  43.                 If i Like "*拾亿零?仟万*" Then i = Replace(i, "拾亿零", "0")
  44.                 If i Like "*拾亿零?佰万*" Then i = Replace(i, "拾亿零", "00")
  45.                 If i Like "*拾亿零?拾万*" Then i = Replace(i, "拾亿零", "000")
  46.                 If i Like "*拾亿零?万*" Then i = Replace(i, "拾亿零", "0000")
  47.                 If i Like "*拾亿零?仟*" Then i = Replace(i, "拾亿零", "00000")
  48.                 If i Like "*拾亿零?佰*" Then i = Replace(i, "拾亿零", "000000")
  49.                 If i Like "*拾亿零?拾*" Then i = Replace(i, "拾亿零", "0000000")
  50.                 If i Like "*拾亿零*" Then i = Replace(i, "拾亿零", "00000000")

  51.                 If i Like "*亿零?佰万*" Then i = Replace(i, "亿零", "0")
  52.                 If i Like "*亿零?拾万*" Then i = Replace(i, "亿零", "00")
  53.                 If i Like "*亿零?万*" Then i = Replace(i, "亿零", "000")
  54.                 If i Like "*亿零?仟*" Then i = Replace(i, "亿零", "0000")
  55.                 If i Like "*亿零?佰*" Then i = Replace(i, "亿零", "00000")
  56.                 If i Like "*亿零?拾*" Then i = Replace(i, "亿零", "000000")
  57.                 If i Like "*亿零*" Then i = Replace(i, "亿零", "0000000")

  58.                 If i Like "*仟万零?仟*" Then i = Replace(i, "仟万零", "000")
  59.                 If i Like "*仟万零?佰*" Then i = Replace(i, "仟万零", "0000")
  60.                 If i Like "*仟万零?拾*" Then i = Replace(i, "仟万零", "00000")
  61.                 If i Like "*仟万零*" Then i = Replace(i, "仟万零", "000000")

  62.                 If i Like "*佰万零?仟*" Then i = Replace(i, "佰万零", "00")
  63.                 If i Like "*佰万零?佰*" Then i = Replace(i, "佰万零", "000")
  64.                 If i Like "*佰万零?拾*" Then i = Replace(i, "佰万零", "0000")
  65.                 If i Like "*佰万零*" Then i = Replace(i, "佰万零", "00000")

  66.                 If i Like "*拾万零?仟*" Then i = Replace(i, "拾万零", "0")
  67.                 If i Like "*拾万零?佰*" Then i = Replace(i, "拾万零", "00")
  68.                 If i Like "*拾万零?拾*" Then i = Replace(i, "拾万零", "000")
  69.                 If i Like "*拾万零*" Then i = Replace(i, "拾万零", "0000")

  70.                 If i Like "*万零?佰*" Then i = Replace(i, "万零", "0")
  71.                 If i Like "*万零?拾*" Then i = Replace(i, "万零", "00")
  72.                 If i Like "*万零*" Then i = Replace(i, "万零", "000")

  73.                 If i Like "*仟零?拾*" Then i = Replace(i, "仟零", "0")
  74.                 If i Like "*仟零*" Then i = Replace(i, "仟零", "00")

  75.                 If i Like "*?万亿元*" Then i = Replace(i, "万亿", "000000000000")
  76.                 If i Like "*?仟亿元*" Then i = Replace(i, "仟亿", "00000000000")
  77.                 If i Like "*?佰亿元*" Then i = Replace(i, "佰亿", "0000000000")
  78.                 If i Like "*?拾亿元*" Then i = Replace(i, "拾亿", "000000000")
  79.                 If i Like "*?亿元*" Then i = Replace(i, "亿", "00000000")
  80.                 If i Like "*?仟万元*" Then i = Replace(i, "仟万", "0000000")
  81.                 If i Like "*?佰万元*" Then i = Replace(i, "佰万", "000000")
  82.                 If i Like "*?拾万元*" Then i = Replace(i, "拾万", "00000")
  83.                 If i Like "*?万元*" Then i = Replace(i, "万", "0000")
  84.                 If i Like "*?仟元*" Then i = Replace(i, "仟", "000")
  85.                 If i Like "*?佰元*" Then i = Replace(i, "佰", "00")
  86.                 If i Like "*?拾元*" Then i = Replace(i, "拾", "0")

  87.                 i = Replace(i, "元整", "")

  88.                 If Not (i Like "*元零?分*") Then i = Replace(i, "元零", "元")
  89.                 If i Like "*元?角" Then i = Replace(i, "角", "0")
  90.                 If i Like "?角?分" Then i = "0." & i
  91.                 If i Like "?角" Then i = "0." & i & "0"
  92.                 If i Like "?分" Then i = "0.0" & i

  93.                 i = Replace(i, "壹", "1")
  94.                 i = Replace(i, "贰", "2")
  95.                 i = Replace(i, "叁", "3")
  96.                 i = Replace(i, "肆", "4")
  97.                 i = Replace(i, "伍", "5")
  98.                 i = Replace(i, "陆", "6")
  99.                 i = Replace(i, "柒", "7")
  100.                 i = Replace(i, "捌", "8")
  101.                 i = Replace(i, "玖", "9")
  102.                 i = Replace(i, "零", "0")
  103.                 i = Replace(i, "亿", "")
  104.                 i = Replace(i, "万", "")
  105.                 i = Replace(i, "仟", "")
  106.                 i = Replace(i, "佰", "")
  107.                 i = Replace(i, "拾", "")
  108.                 i = Replace(i, "元", ".")
  109.                 i = Replace(i, "角", "")
  110.                 i = Replace(i, "分", "")
  111.                 i = Replace(i, "整", "")

  112.                 j = "(¥:" & i & "元)"
  113.                 If n = 1 Then Selection.InsertBefore Text:=j Else Selection.InsertAfter Text:=j
  114.                 Exit Do
  115.             End If
  116.         Loop
  117.         Selection.MoveRight unit:=wdCharacter, Count:=1
  118.     Loop
  119.     ActiveDocument.Paragraphs.Last.Range.Delete
  120.     MsgBox "处理完毕!!!!!!" & vbCr & "请注意!中文大写金额最大不得超过<壹仟亿元整>,否则转换将不正确!" & vbCr & _
  121.     "请检查文中是否有<红色/加粗/重波浪线>金额(超过限制),手动转换!" _
  122.     & vbCr & "本宏为 v1.00 Beta 版本,数据超过10亿可能转换不正确,最大不得超过1千亿!", vbOKOnly + vbExclamation, "人民币中文大写转阿拉伯数字"
  123. End Sub
复制代码


TA的精华主题

TA的得分主题

发表于 2016-9-10 10:27 | 显示全部楼层
本帖最后由 13907933959 于 2016-9-10 14:12 编辑

师傅好!
刚在附件内测试了“人民币中文大写转阿拉伯数字”的宏,发现还有几处转换后的阿拉伯数字好象不太准确。

附件1.rar

2.97 KB, 下载次数: 5

TA的精华主题

TA的得分主题

发表于 2016-9-10 22:32 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2016-9-11 07:35 | 显示全部楼层
本帖最后由 13907933959 于 2016-9-11 09:52 编辑

前辈好!
感谢前辈多次出手相助!
看到前辈录制的屏幕演示,能将阿拉伯数字转化为中文大写数字,但不知所有的阿拉伯数字都能完美的转化?
还有前辈可能没有注意到,上面帖子是要将中文大写数字转化为阿拉伯数字。
请前辈查看下面的附件,谢谢!


大小写附件.rar

4.63 KB, 下载次数: 7

阿拉伯数字转中文大、小写数字.rar

3.61 KB, 下载次数: 5

TA的精华主题

TA的得分主题

 楼主| 发表于 2016-9-11 18:13 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
139:最近经过几天的努力,当然我水平不高,完善不少!现在还有一些疑难数据未攻克(就是佰亿元量级的数据未攻克,致使数据不正确!如果数据是佰亿量级以下的,可能会正确,但转换后也需要确认检查!),我现在发上来最新版本宏代码和测试附件(你的附件不如我的附件,看我的吧!今天发现进坛又换验证方式了,中午没进来,为防以后进不来,我现在留下我的联系邮箱,有事给我发邮件,万一我上不来的话!——我的电子邮箱:ln1400014884@163.com): macro 人民币中文大写转阿拉伯数字 v0.99.1.rar (10.66 KB, 下载次数: 24)

TA的精华主题

TA的得分主题

发表于 2016-9-12 07:56 | 显示全部楼层
本帖最后由 13907933959 于 2016-9-12 08:28 编辑
413191246se 发表于 2016-9-11 18:13
139:最近经过几天的努力,当然我水平不高,完善不少!现在还有一些疑难数据未攻克(就是佰亿元量级的数据 ...

师傅好!
这个可能看似是一个简单的问题,其实是一个难度很大和相当费脑筋的难题!师傅的转换正确率能到这个程度以经相当的不易了!师傅辛苦了!
师傅、我测试后发现、类似“玖拾亿元零壹分”、“陆拾亿元零柒角”转换后好象还是有不正确的现象。

TA的精华主题

TA的得分主题

发表于 2016-9-12 12:33 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
kjk.gif

TA的精华主题

TA的得分主题

发表于 2016-9-12 15:46 | 显示全部楼层

前辈好!
看到前辈的动画演示,的确可准确转换,可否恳请前辈把代码贴出来分享!在下将感激不尽!

TA的精华主题

TA的得分主题

 楼主| 发表于 2016-9-12 22:27 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
顶以更新!(我未解决的金额数据全在《附件---疑难》这个文档中,要解决需要时日。)
139请看1楼更新!(你要处理的数值如果不大于10亿的话,可以应用此宏了!)
如果有哪位高手对此宏感兴趣,不妨在我的基础上继续编程,或全新编程此宏贡献出来造福大家。
谢谢各位!

TA的精华主题

TA的得分主题

发表于 2016-9-13 09:29 | 显示全部楼层
413191246se 发表于 2016-9-12 22:27
顶以更新!(我未解决的金额数据全在《附件---疑难》这个文档中,要解决需要时日。)
139请看1楼更新!( ...

师傅辛苦了!!!
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2025-1-13 17:00 , Processed in 0.026329 second(s), 10 queries , Gzip On, MemCache On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

沪公网安备 31011702000001号 沪ICP备11019229号-2

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:李志群律师

快速回复 返回顶部 返回列表