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
