VBA基础八：汉字数字转阿拉伯数字

Option Explicit

Sub test() '汉字转阿拉伯数字模块
Dim tm, ii
Dim arrPre, arrRes
arrPre = Range("A2:A20") '待转换汉字存放位置A列，可修改
ReDim arrRes(1 To UBound(arrPre), 1 To 1)
For ii = 1 To UBound(arrPre)
arrRes(ii, 1) = toNum(arrPre(ii, 1))
Next ii
Range("B2:B20") = arrRes '写入转换后的阿拉伯数字位置B列，可修改
End Sub

Private Function toNum(myStr)
'==========================================================
'中文小写转阿拉伯数字函数
'Writen by 时光鸟
'2012-12-24 于 武汉

'ver 2.0 beta (update 2013-6-17)
'*改进数量级左侧为非转化文本时的转化Bug(感谢excelhome论坛"星语心愿"朋友的bug反馈)
'ver 1.9 beta (update 2013-1-12)
'*改进极个别情况最右侧数量级的右侧为非转化文本时的转化Bug
'ver 1.8 beta (update 2012-12-30)
'*改进少数情况下把"二"习惯用成"两"的时候的转化问题
'*改进极个别情况下"〇"或"零"后直接跟数量级时的转化问题
'*对小部分中文小写数字的不规范表达增加纠错转化功能
'*增加对中文小写乘法口诀转化的功能支持
'ver 1.7 beta (update 2012-12-29)
'*改进个别情况下需要在中文小写中同时使用〇和零时的转化问题
'*优化代码结构，提升效率
'ver 1.6 beta (updat'e 2012-12-28)
'*解决了首位只有数量级时这种简化表达方式转化不正确的Bug
'ver 1.5 beta (update 2012-12-27)
'*解决了〇右侧有多个数量级时某种情况替换数量不正确的Bug
'ver 1.4 beta (update 2012-12-27)
'*解决了〇右侧有多个数量级时替换数量不正确的Bug
'ver 1.3 beta (update 2012-12-26)
'*解决了连续有多个数量级时转化不正确的Bug
'ver 1.2 beta (update 2012-12-26)
'*解决了中文小写中某种情况下使用汉字“零”时转化不正确的Bug
'ver 1.1 beta (update 2012-12-25)
'*解决了中文小写中含有〇的情况下时转化不正确的Bug
'ver 1.0 beta (update 2012-12-24)
'*中文小写转阿拉伯数字正常表达方式转化函数发布
'==========================================================

Dim strG$, strL$, strN$, strZ$, findZ$, addZ$
Dim i%, m%, n%, k%, Lv%, Rv%, Lx%, Rx%, R1%, R2%, Ly%, Ry%, Tx%, flagP%
strG = "十百千万亿"
strL = "一二三四五六七八九"
strN = "123456789"
strZ = "〇零"
If myStr = "" Then Exit Function
While (InStr(myStr, Left(strZ, 1)) + InStr(myStr, Right(strZ, 1)) > 0)
Lv = InStr(myStr, Left(strZ, 1))
Rv = InStr(myStr, Right(strZ, 1))
If Lv > 0 Then If Rv = 0 Or Rv > Lv Then findZ = Left(strZ, 1)
If Rv > 0 Then If Lv = 0 Or Lv > Rv Then findZ = Right(strZ, 1)
m = InStr(myStr, findZ)
If m < Len(myStr) And InStr(strG, Mid(myStr, m + 1, 1)) Then
myStr = Left(myStr, m) & "一" & Mid(myStr, m + 1)
End If
If Mid(myStr, m - 1, 1) <> "" Then Lx = InStr(strG, Mid(myStr, m - 1, 1)) Else Lx = 0
If Mid(myStr, m + 2, 1) <> "" Then R1 = InStr(strG, Mid(myStr, m + 2, 1)) Else R1 = 0
If Mid(myStr, m + 3, 1) <> "" Then R2 = InStr(strG, Mid(myStr, m + 3, 1)) Else R2 = 0
If R2 = 5 Then Rx = R1 + R2 + 3 Else Rx = R1 + R2
If Lx > 0 And Lx < R1 Then Rx = 0
If Lx > R1 And Lx < R2 Then Rx = R1
If Lx = 5 Then Lx = Lx + 3
If Lx = 0 And Rx = 0 Then Lx = 2
myStr = Replace(myStr, findZ, Mid(10 ^ (Lx - Rx - 1), 2), 1, 1)
Wend
Do
If Len(myStr) < 2 Then Exit Do
If Mid(myStr, n + 1, 1) <> "" Then Ly = InStr(strG, Mid(myStr, n + 1, 1)) Else Ly = 0
If Mid(myStr, n + 2, 1) <> "" Then Ry = InStr(strG, Mid(myStr, n + 2, 1)) Else Ry = 0
If Ly > 0 And Ry > 0 Then
If Ly = 5 Then addZ = Mid(10 ^ (Ly + 3), 2) Else addZ = Mid(10 ^ Ly, 2)
myStr = Left(myStr, n + 1) & addZ & Mid(myStr, n + 2)
n = n + Len(addZ)
Else
n = n + 1
End If
Loop Until (n = Len(myStr) - 1)
If Len(myStr) > 3 And InStr(strL, Left(myStr, 1)) * InStr(strL, Mid(myStr, 2, 1)) Then
If Len(myStr) = 4 And Mid(myStr, 3, 1) = "得" Then myStr = Left(myStr, 1) & "×" & Replace(Mid(myStr, 2), "得", "=")
If Len(myStr) < 6 And InStr(strL, Mid(myStr, 3, 1)) > 0 And InStr(strG, Mid(myStr, 4, 1)) > 0 Then
myStr = Left(myStr, 1) & "×" & Mid(myStr, 2, 1) & "=" & Mid(myStr, 3)
End If
End If
If InStr(myStr, "两") > 0 Then myStr = Replace(myStr, "两", "二")

If InStr(strG, Left(myStr, 1)) > 0 Then myStr = "一" & myStr
While (flagP <= Len(myStr) - 2)
flagP = flagP + 1
If InStr(strG, Mid(myStr, flagP + 1, 1)) > 0 And InStr(strG & strL & strZ & strN & "1234567890", Mid(myStr, flagP, 1)) = 0 Then
myStr = Left(myStr, flagP) & "一" & Mid(myStr, flagP + 1)
End If
Wend

If Len(myStr) > 1 Then
For i = Len(myStr) - 1 To 1 Step -1
k = InStr(strG, Right(myStr, 1))
If k = 5 Then myStr = myStr & Mid(10 ^ (k + 3), 2) Else If k > 0 Then myStr = myStr & Mid(10 ^ k, 2)
If k = 0 Then
Tx = InStr(strG, Mid(myStr, i, 1))
If Tx > 0 And InStr(strL, Mid(myStr, i + 1, 1)) = 0 And Mid(myStr, i + 1, 1) <> "0" Then
If Tx = 5 Then addZ = Mid(10 ^ (Tx + 3), 2) Else addZ = Mid(10 ^ Tx, 2)
myStr = Left(myStr, i) & addZ & Mid(myStr, i + 1)
End If
End If
Next i
End If
For i = 1 To Len(strL)
If i <= Len(strG) And InStr(myStr, Mid(strG, i, 1)) Then myStr = Replace(myStr, Mid(strG, i, 1), "")
If InStr(myStr, Mid(strL, i, 1)) > 0 Then myStr = Replace(myStr, Mid(strL, i, 1), Mid(strN, i, 1))
Next i
toNum = myStr
End Function