Option Explicit
Sub test() '汉字转阿拉伯数字模块Dim tm, iiDim arrPre, arrResarrPre = 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 iiRange("B2:B20") = arrRes '写入转换后的阿拉伯数字位置B列，可修改End Sub
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 FunctionWhile (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)WendDo 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 IfLoop 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 IfEnd IfIf InStr(myStr, "两") > 0 Then myStr = Replace(myStr, "两", "二")
If InStr(strG, Left(myStr, 1)) > 0 Then myStr = "一" & myStrWhile (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 IfWend
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 iEnd IfFor 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 itoNum = myStrEnd Function