我的VBA自定义函数研习收获

weiyingde · 发表于 2019-10-31 19:09

本帖最后由 weiyingde 于 2019-11-1 11:14 编辑

Public Function DaXie(ByVal Num As Double)       ' 人民币中文大写函数
   Place = "分角元拾佰仟万拾佰仟亿拾佰仟万"
   Dn = "壹贰叁肆伍陆柒捌玖"
   D1 = "整零元零零零万零零零亿零零零万"
   If Num < 0 Then FuHao = "（负）"
   Num = Format(Abs(Num), "###0.00") * 100
   If Num > 999999999999999# Then: DaXie = "数字超出转换范围!!": Exit Function
   If Num = 0 Then: DaXie = "零元零分": Exit Function
   NumA = Trim(Str(Num))
   NumLen = Len(NumA)
   For j = NumLen To 1 Step -1    ' 数字转换过程
   temp = Val(Mid(NumA, NumLen - j + 1, 1))
   If temp <> 0 Then             ' 非零数字转换
      NumC = NumC & Mid(Dn, temp, 1) & Mid(Place, j, 1)
   Else                         ' 数字零的转换
      If right(NumC, 1) <> "零" Then
         NumC = NumC & Mid(D1, j, 1)
      Else
         Select Case j          ' 特殊数位转换
               Case 1
               NumC = left(NumC, Len(NumC) - 1) & Mid(D1, j, 1)
               Case 3, 11
               NumC = left(NumC, Len(NumC) - 1) & Mid(D1, j, 1) & "零"
               Case 7
               If Mid(NumC, Len(NumC) - 1, 1) <> "亿" Then
                  NumC = left(NumC, Len(NumC) - 1) & Mid(D1, j, 1) & "零"
               End If
               Case Else
         End Select
      End If
   End If
   Next
   DaXie = FuHao & Trim(NumC)
End Function

Function DxToN(ss)
For i% = 1 To 9
      ss = Replace(ss, Mid("壹贰叁肆伍陆柒捌玖", i, 1), i)
      ss = Replace(ss, Mid("一二三四五六七八九", i, 1), i)
Next
For i% = Len(ss) To 1 Step -1
      S$ = Mid$(ss, i, 1)
      x% = InStr("分角圆拾佰仟万拾佰仟亿拾佰仟兆", S)
      If x = 0 Then x% = InStr("分毛元十百千萬十百千億十百千兆", S)
      If x Then j% = IIf(j% < x, x, ((j - 3) \ 4) * 4 + x)
      If Val(S) Then M# = M# + (S & String(j - 1, "0")) / 100
Next
DxToN = Round(M, 2)
If InStr(ss, "-") Or InStr(ss, "负") Then DxToN = -DxToN
End Function

补充内容 (2020-2-28 22:20):
只能到万位
Function DTX(str3)
Dim str$, i%
str = "〇一二三四五六七八九"
str2 = "十百千万"
For i = 1 To 4
      str3 = Replace(str3, Mid(str2, i, 1), "*" & 10 ^ i & "+")
Next
For i = 1 To 10
      str3 = Replace(str3, Mid(str, i, 1), i - 1)
Next
If Left(str3, 1) = "*" Then str3 = 1 & str3
If Right(str3, 1) = "+" Then str3 = Mid(str3, 1, Len(str3) - 1)
DTX = Evaluate("(" & str3 & ")*1")
End Function

weiyingde · 发表于 2019-11-1 10:51

见http://club.excelhome.net/thread-974120-1-1.html
时光鸟朋友的自定义函数。
Private Function toNum(myStr)
'==========================================================
'中文小写转阿拉伯数字函数
'Writen by 时光鸟
'2012-12-24 于武汉

'ver 2.0 beta (update 2013-6-17)
'*改进数量级左侧为非转化文本时的转化Bug(感谢excelhome论坛"星语心愿"朋友的反馈)
'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

补充内容 (2024-8-12 18:53):
下面是  把大写中文金额转为阿拉伯数字
见本网站：https://club.excelhome.net/thread-66279-1-2.html
' 试编写金额中文大写转数字函数
' lin jin xiang 18/10/2004

Function SuZi(A As String) ' 人民币中...

weiyingde · 发表于 2019-11-1 11:53

本帖最后由 weiyingde 于 2019-11-1 20:09 编辑

写在前头
下面是自己的一个自定义函数，作用是将阿拉伯数字转换为中文大写数字，实现的作用
如text(number,"[dbnum1"]和text[number,"[dbnum2]"以及Excel隐藏的工作表函数
Numberstring的作用。
这两个函数确实很强大，很好用，但在Excel工作环境中好用，到了pptVBA环境下，使用过程中，
冷不防要后台启动Excel.application，造成当前ppt运行极不稳定，常常突发意外，所以在ppt中，
这两个好用的函数，竟不能排上好的用场，只好另辟蹊径。想到了VBA自定义函数。
自定义函数中可以借鉴的诸如人民币大写函数，网上有大量事例，可以借鉴，然而不是极其繁琐
就是精炼直至：不想麻烦，繁琐的自然不在考虑中；简单之至，又一时半载消化不了，只好硬着头皮自力更生。但目前只能写到一半，脑力有限，发在此处，如有好心人士路过，希望补充完善。
先谢了。
Function XtD(n As Integer, Optional k As Integer)
  Select Case n
      Case 0
         sr = IIf(k = 1, "0", "零")
      Case 10
         sr = IIf(k = 1, "十", "拾")
      Case 11
         sr = IIf(k = 1, "十一", "拾壹")
      Case 1 To 9
         sr = IIf(k = 1, Choose(n, "一", "二", "三", "四", "五", "六", "七", "八", "九"), Choose(n, "壹", "贰", "叁", "肆", "伍", "陆", "柒", "捌", "玖"))
      Case 11 To 99
         ssh = Int(n / 10)
         wsh = n - ssh * 10
         If wsh = 0 Then
            sr = IIf(k = 1, Choose(ssh, "一", "二", "三", "四", "五", "六", "七", "八", "九") & "十", Choose(ssh, "壹", "贰", "叁", "肆", "伍", "陆", "柒", "捌", "玖") & "拾")
         Else
            sr = IIf(k = 1, Choose(ssh, "一", "二", "三", "四", "五", "六", "七", "八", "九") & "十" & Choose(wsh, "一", "二", "三", "四", "五", "六", "七", "八", "九"), Choose(ssh, "壹", "贰", "叁", "肆", "伍", "陆", "柒", "捌", "玖") & "拾" & Choose(wsh, "壹", "贰", "叁", "肆", "伍", "陆", "柒", "捌", "玖"))
         End If
      Case 100
         sr = IIf(k = 1, "一百", "壹佰")
      Case 101 To 999
            ssh = Int(n / 100)
            wsh = n - ssh * 100
            zsh2 = Int(wsh / 10)
            wsh2 = wsh Mod 10
            If zsh2 = 0 Then
               If wsh2 = 0 Then
                  sr = IIf(k = 1, Choose(ssh, "一", "二", "三", "四", "五", "六", "七", "八", "九") & "百", Choose(ssh, "壹", "贰", "叁", "肆", "伍", "陆", "柒", "捌", "玖") & "佰")
               Else
                  sr1 = IIf(k = 1, Choose(Val(Left(n, 1)), "一", "二", "三", "四", "五", "六", "七", "八", "九") & "百", Choose(Val(Left(n, 1)), "壹", "贰", "叁", "肆", "伍", "陆", "柒", "捌", "玖") & "佰")
                  sr2 = IIf(k = 1, "○", "零")
                  sr3 = IIf(k = 1, Choose(Val(Right(n, 1)), "一", "二", "三", "四", "五", "六", "七", "八", "九"), Choose(Val(Right(n, 1)), "壹", "贰", "叁", "肆", "伍", "陆", "柒", "捌", "玖"))
                  sr = sr1 & sr2 & sr3
               End If
            ElseIf zsh2 >= 1 Then
               If wsh2 = 0 Then
                  sr1 = IIf(k = 1, Choose(Val(Left(n, 1)), "一", "二", "三", "四", "五", "六", "七", "八", "九") & "百", Choose(Val(Left(n, 1)), "壹", "贰", "叁", "肆", "伍", "陆", "柒", "捌", "玖") & "佰")
                  sr2 = IIf(k = 1, Choose(Val(Mid(n, 2, 1)), "一", "二", "三", "四", "五", "六", "七", "八", "九") & "十", Choose(Val(Mid(n, 2, 1)), "壹", "贰", "叁", "肆", "伍", "陆", "柒", "捌", "玖") & "拾")
                  sr = sr1 & sr2
               Else
                  sr1 = IIf(k = 1, Choose(Val(Left(n, 1)), "一", "二", "三", "四", "五", "六", "七", "八", "九") & "百", Choose(Val(Left(n, 1)), "壹", "贰", "叁", "肆", "伍", "陆", "柒", "捌", "玖") & "佰")
                  sr2 = IIf(k = 1, Choose(Val(Mid(n, 2, 1)), "一", "二", "三", "四", "五", "六", "七", "八", "九") & "十", Choose(Val(Mid(n, 2, 1)), "壹", "贰", "叁", "肆", "伍", "陆", "柒", "捌", "玖") & "拾")
                  sr3 = IIf(k = 1, Choose(Val(Right(n, 1)), "一", "二", "三", "四", "五", "六", "七", "八", "九"), Choose(Val(Right(n, 1)), "壹", "贰", "叁", "肆", "伍", "陆", "柒", "捌", "玖"))
                  sr = sr1 & sr2 & sr3
               End If
            End If
         Case 1000 To 9999
               ssh = Int(N / 1000)
               wsh = N Mod 1000
               zsh1 = Int(wsh / 100)
               wsh1 = wsh - 100 * zsh1
               zsh2 = Int(wsh1 / 10)
               wsh2 = wsh1 - 10 * zsh2
               If wsh = 0 Then
                  sr = IIf(k = 1, Choose(Val(left(N, 1)), "一", "二", "三", "四", "五", "六", "七", "八", "九") & "千", Choose(Val(left(N, 1)), "壹", "贰", "叁", "肆", "伍", "陆", "柒", "捌", "玖") & "仟")
               Else
                  If zsh1 <> 0 Then
                     If zsh2 <> 0 Then
                        If wsh2 <> 0 Then
                           For i = 1 To 4
                           If k = 1 Then
                              sr = sr & Choose(Val(Mid(N, i, 1)), "一", "二", "三", "四", "五", "六", "七", "八", "九") & Choose(i, "千", "百", "十", "")
                           Else
                              sr = sr & Choose(Val(Mid(N, i, 1)), "壹", "贰", "叁", "肆", "伍", "陆", "柒", "捌", "玖") & Choose(i, "仟", "佰", "拾", "")
                           End If
                           Next
                        Else
                           For i = 1 To 3
                           If k = 1 Then
                              sr = sr & Choose(Val(Mid(N, i, 1)), "一", "二", "三", "四", "五", "六", "七", "八", "九") & Choose(i, "千", "百", "十")
                           Else
                              sr = sr & Choose(Val(Mid(N, i, 1)), "壹", "贰", "叁", "肆", "伍", "陆", "柒", "捌", "玖") & Choose(i, "仟", "佰", "拾")
                           End If
                           Next
                        End If
                     Else
                        If wsh2 <> 0 Then
                              sr1 = IIf(k = 1, Choose(Val(left(N, 1)), "一", "二", "三", "四", "五", "六", "七", "八", "九") & "千", Choose(Val(left(N, 1)), "壹", "贰", "叁", "肆", "伍", "陆", "柒", "捌", "玖") & "仟")
                              sr2 = IIf(k = 1, Choose(Val(right(N, 1)), "一", "二", "三", "四", "五", "六", "七", "八", "九"), Choose(Val(right(N, 1)), "壹", "贰", "叁", "肆", "伍", "陆", "柒", "捌", "玖"))
                              sr = sr1 & IIf(k = 1, "○", "零") & sr2
                        Else
                              sr1 = IIf(k = 1, Choose(Val(left(N, 1)), "一", "二", "三", "四", "五", "六", "七", "八", "九") & "千", Choose(Val(left(N, 1)), "壹", "贰", "叁", "肆", "伍", "陆", "柒", "捌", "玖") & "仟")
                              sr2 = IIf(k = 1, Choose(Val(Mid(N, 2, 1)), "一", "二", "三", "四", "五", "六", "七", "八", "九") & "百", Choose(Val(Mid(N, 2, 1)), "壹", "贰", "叁", "肆", "伍", "陆", "柒", "捌", "玖") & "佰")
                              sr = sr1 & sr2
                        End If
                     End If
                  Else
                     If zsh2 <> 0 Then
                           sr1 = IIf(k = 1, Choose(Val(left(N, 1)), "一", "二", "三", "四", "五", "六", "七", "八", "九") & "千", Choose(Val(left(N, 1)), "壹", "贰", "叁", "肆", "伍", "陆", "柒", "捌", "玖") & "仟")
                           sr2 = IIf(k = 1, Choose(Val(Mid(N, 3, 1)), "一", "二", "三", "四", "五", "六", "七", "八", "九") & "十", Choose(Val(Mid(N, 3, 1)), "壹", "贰", "叁", "肆", "伍", "陆", "柒", "捌", "玖") & "拾")
                           sr3 = IIf(k = 1, Choose(Val(right(N, 1)), "一", "二", "三", "四", "五", "六", "七", "八", "九"), Choose(Val(right(N, 1)), "壹", "贰", "叁", "肆", "伍", "陆", "柒", "捌", "玖"))
                           sr = sr1 & IIf(k = 1, "○", "零") & sr2 & sr3
                     Else
                           sr1 = IIf(k = 1, Choose(Val(left(N, 1)), "一", "二", "三", "四", "五", "六", "七", "八", "九") & "千", Choose(Val(left(N, 1)), "壹", "贰", "叁", "肆", "伍", "陆", "柒", "捌", "玖") & "仟")
                           sr2 = IIf(k = 1, Choose(Val(right(N, 1)), "一", "二", "三", "四", "五", "六", "七", "八", "九"), Choose(Val(right(N, 1)), "壹", "贰", "叁", "肆", "伍", "陆", "柒", "捌", "玖"))
                           sr = sr1 & IIf(k = 1, "○", "零") & sr2
                     End If
                  End If
            End If

End Select
XtD = sr
End Function

weiyingde · 发表于 2019-11-1 15:04

这一个找了好久，实现的作用与上同，可惜只能实现一种转换，容自己日后改造，发于此以备后用。
'版权声明：本文为CSDN博主「miaozk2006」的原创文章，遵循 CC 4.0 BY-SA 版权协议，转载请附上原文出处链接及本声明。
'原文链接：https://blog.csdn.net/miaozk2006/article/details/82417018
Public Function NumTstr(StrEng As String) As String
Dim intLen As Integer, intCounter As Integer
Dim strCh As String, strTempCh As String
Dim strSeqCh1 As String, strSeqCh2 As String
Dim strEng2Ch As String
strEng2Ch = "零壹贰叁肆伍陆柒捌玖"
strSeqCh1 = " 拾佰仟拾佰仟拾佰仟拾佰仟"
strSeqCh2 = " 万亿兆"
StrEng = CStr(CDec(StrEng))
intLen = Len(StrEng)

If Not IsNumeric(StrEng) Or StrEng Like "*.*" Or StrEng Like "*-*" Then
If Trim(StrEng) <> "" Then NumTstr = "无效的数字": Exit Function
End If

For intCounter = 1 To intLen
strTempCh = Mid(strEng2Ch, Val(Mid(StrEng, intCounter, 1)) + 1, 1)
If strTempCh = "零" And intLen <> 1 Then
   If Mid(StrEng, intCounter + 1, 1) = "0" Or (intLen - intCounter + 1) Mod 4 = 1 Then
      strTempCh = ""
   End If
Else
      strTempCh = strTempCh & Trim(Mid(strSeqCh1, intLen - intCounter + 1, 1))
End If
If (intLen - intCounter + 1) Mod 4 = 1 Then
   strTempCh = strTempCh & Mid(strSeqCh2, (intLen - intCounter + 1) \ 4 + 1, 1)
   If intCounter > 3 Then
      If Mid(StrEng, intCounter - 3, 4) = "0000" Then strTempCh = Left(strTempCh, Len(strTempCh) - 1)
   End If
End If
   strCh = strCh & Trim(strTempCh)
Next
NumTstr = strCh
End Function

weiyingde · 发表于 2019-11-1 15:26

本帖最后由 weiyingde 于 2019-11-1 20:08 编辑

做了一下改造，text(number,"[dbnum1"]和text[number,"[dbnum2]"以及Excel隐藏的工作表函数
Numberstring的作用。
此程序有bug，1692，壹陆仟玖佰贰拾，显然有误，所以有待完善。‘’‘’‘’‘’‘’‘’‘’‘’‘’‘’‘’‘’‘’‘’‘’‘’‘’‘’‘’‘’‘’''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Function NumTstr(StrEng As String, kg As Integer) As String
Dim intLen As Integer, intCounter As Integer
Dim strCh As String, strTempCh As String
Dim strSeqCh1 As String, strSeqCh2 As String
Dim strEng2Ch As String
strEng2Ch = IIf(kg = 1, "一二三四五六七八九", "零壹贰叁肆伍陆柒捌玖")
strSeqCh1 = IIf(kg = 1, "十百千十百千十百千十百千", "拾佰仟拾佰仟拾佰仟拾佰仟")
strSeqCh2 = " 万亿兆"
StrEng = CStr(CDec(StrEng))
intLen = Len(StrEng)

If Not IsNumeric(StrEng) Or StrEng Like "*.*" Or StrEng Like "*-*" Then
If Trim(StrEng) <> "" Then NumTstr = "无效的数字": Exit Function
End If

For intCounter = 1 To intLen
strTempCh = Mid(strEng2Ch, Val(Mid(StrEng, intCounter, 1)) + 1, 1)
If strTempCh = "零" And intLen <> 1 Or strTempCh = "○" And intLen <> 1 Then
   If Mid(StrEng, intCounter + 1, 1) = "0" Or (intLen - intCounter + 1) Mod 4 = 1 Then
      strTempCh = ""
   End If
Else
      strTempCh = strTempCh & Trim(Mid(strSeqCh1, intLen - intCounter + 1, 1))
End If
If (intLen - intCounter + 1) Mod 4 = 1 Then
   strTempCh = strTempCh & Mid(strSeqCh2, (intLen - intCounter + 1) \ 4 + 1, 1)
   If intCounter > 3 Then
      If Mid(StrEng, intCounter - 3, 4) = "0000" Then strTempCh = Left(strTempCh, Len(strTempCh) - 1)
   End If
End If
   strCh = strCh & Trim(strTempCh)
Next
NumTstr = strCh
End Function

weiyingde · 发表于 2019-11-15 11:48

Public Function 数组合并(rng As Range, rg As Range, col1 As Integer, col2 As Integer)
Rem rng、rg的行数必须相同
Rem rng、rg 分别为要合并的数组数据所在区域的第一个单元格，col1、col2分别为所在区域的列数
Dim 合rr()
rws = rng.CurrentRegion.Rows.Count - 1
arr = rng.Resize(rws, col1)
brr = rg.Resize(rws, col2)
col = col1 + col2
ReDim 合rr(1 To rws, 1 To col)
For i = 1 To rws
      For j = 1 To col
         If j <= col1 Then
            合rr(i, j) = arr(i, j)
         Else
            合rr(i, j) = brr(i, j - col1)
         End If
      Next
Next
数组合并 = 合rr
End Function

weiyingde · 发表于 2020-2-7 11:41

本帖最后由 weiyingde 于 2020-2-7 11:44 编辑

见：'http://club.excelhome.net/thread-974120-3-1.html,27楼
Private Function toNum1(mystr As String) As Double 'mystr 数据已经经过toNumBZH函数处理
Dim i As Integer, myPos1 As Integer, myPos2%, falg% 'falg标志最高位在字串中出现位置，myPos2 表示最高位次数
Dim str1 As String
Dim comString As String
comString = "十百千万┩兆╊亿0123456789" '加入┩╊为处理方便，如在有可能出现的场合可先清除
If mystr = "" Then
      toNum1 = 0
      Exit Function
End If
myPos2 = 0
falg = 0
For i = 1 To Len(mystr)
      str1 = Mid(mystr, i, 1)
      myPos1 = InStr(1, comString, str1, vbBinaryCompare)
      Select Case myPos1
      Case 1 To 8
         If myPos1 >= myPos2 Then
            falg = i
            myPos2 = myPos1
         End If
      End Select
Next
Select Case falg
Case 0 '代表字串为纯数字
      Dim mynum As Long
      For i = Len(mystr) To 1 Step -1
         mynum = mynum + Val(Mid(mystr, i, 1)) * 10 ^ (Len(mystr) - i)
      Next
      toNum1 = mynum
      Exit Function
Case 1 '万三千....
      toNum1 = toNum1(Right(mystr, Len(mystr) - falg)) + 10 ^ (myPos2)
Case 2
      Dim temp As String
      temp = Mid(mystr, 1, 1)
      If InStr(1, comString, temp, vbBinaryCompare) > 8 Then '代表第一位为数字第二位为位符如6万
         toNum1 = toNum1(Right(mystr, Len(mystr) - falg)) + Val(temp) * 10 ^ (myPos2)
      Else '如十万、百万...万万
         toNum1 = toNum1(Right(mystr, Len(mystr) - falg)) + 10 ^ (InStr(1, comString, temp, vbBinaryCompare) + myPos2)
      End If
Case Else
      toNum1 = toNum1(Right(mystr, Len(mystr) - falg)) + toNum1(Left(mystr, falg - 1)) * 10 ^ (myPos2)
End Select
End Function

Private Function toNumBZH(mystr As String) As String '此函数将输入的中文数字（允许大写、小写、数字、西文空格混编，如有其它字符出现则输出为空串)
Dim i%, k%, k1%, myPos1%
Dim str1$, comString$
comString = "一壹二贰三叁四肆五伍六陆七柒八捌九玖零〇十拾百佰千仟万萬亿億兆0123456789"
mystr = Replace(mystr, " ", "")
mystr = Replace(mystr, "貳", "2")
mystr = Replace(mystr, "陸", "6")
mystr = Replace(mystr, "两", "2")
For i = 1 To Len(mystr)
      str1 = Mid(mystr, i, 1)
      myPos1 = InStr(1, comString, str1, vbBinaryCompare)
      If myPos1 = 0 Then Exit Function
      Select Case myPos1
      Case 1 To 18
         mystr = Replace(mystr, str1, Trim(Str(Int((myPos1 + 1) / 2))))
      Case 19, 20
         mystr = Replace(mystr, str1, "0")
      Case 22, 24, 26, 28, 30
         mystr = Replace(mystr, str1, Mid(comString, myPos1 - 1, 1))
      End Select
Next
For i = 1 To Len(mystr)
      str1 = Mid(mystr, i, 1)
      myPos1 = InStr(1, comString, str1, vbBinaryCompare)
      If myPos1 >= 21 And myPos1 <= 31 Then k1 = i
      If str1 = "0" Then
         k = InStr(1, comString, Mid(mystr, i + 1, 1), vbBinaryCompare)
         If k >= 21 And k <= 31 And Val(Mid(mystr, k1 + 1, i - k1)) = 0 Then mystr = Left$(mystr, i - 1) & "1" & Right$(mystr, Len(mystr) - i)
      End If
Next
toNumBZH = mystr
End Function说明：经测试，比时光鸟朋友的中文小写转阿拉伯数字的兼容性要好些。向原创说声谢谢。

weiyingde · 发表于 2020-2-12 18:42

利用网络互译，借鉴别人的过程，做成函数，方便反复调用，源代码使用一个过程和一个函数联合做成的，为了避免“拖儿带女”，做成一个。可惜忘了引处，在此遗憾。
Public Function 有道互译(ByRef isr As String)                                                    '对suwenkai老师的代码进行了补充，感谢 much 的帮助
Dim pd$, exp$, i%, j%
Set js = CreateObject("scriptcontrol") '
Set ms = CreateObject("msscriptcontrol.scriptcontrol")
ms.Language = "JavaScript"
js.Language = "jscript"
exp = ""
pd = "type=AUTO"
ssr = ms.Eval("encodeURI('" & Replace(isr, "'", "\'") & "');")
pd = pd & "&i=" & Replace(Replace(Replace(ssr, "%", "%C2%"), "%C2%E", "%C3%A"), "%C2%20", " ")
pd = pd & "&doctype=json"
URL = "http://fanyi.youdao.com/translate?smartresult=dict&smartresult=rule&smartresult=ugc&sessionFrom=null"
With CreateObject("msxml2.xmlhttp")
      .Open "POST", URL, False
      .setRequestHeader "Host", "fanyi.youdao.com"
      .setRequestHeader "Connection", "keep-alive"
      .setRequestHeader "Content-Length", "137"
      .setRequestHeader "Accept", "application/json, text/javascript, */*; q=0.01"
      .setRequestHeader "Origin", "http://fanyi.youdao.com"
      .setRequestHeader "X-Requested-With", "XMLHttpRequest"
      .setRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 6.1; WOW64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/41.0.2272.101 Safari/537.36"
      .setRequestHeader "Content-Type", "application/x-www-form-urlencoded; charset=UTF-8"
      .setRequestHeader "Referer", "http://fanyi.youdao.com/"
      .setRequestHeader "Accept-Encoding", "gzip, deflate"
      .setRequestHeader "Accept-Language", "zh-CN,zh;q=0.8"
      .send (pd)
      js.addcode "renahu=" & .responseText
      For j = 1 To js.Eval("renahu.translateResult[0].length")
         exp = exp & js.Eval("renahu.translateResult[0][" & j - 1 & "].tgt")
      Next
      有道互译 = exp
   End With
End Function

weiyingde · 发表于 2020-2-13 20:57

前言：花了一个下午的时间，进行探究，写成了一个基于Excel2010网络环境下环境下通译函数。为了自便和便人，贴在此处，后续篇将是不需要网络的英汉互译函数，希望能成功，如果你正好路过此处，请提供相关代码，在此对不知名的你先表示感谢。
   另外，这个函数，又套小函数，函数引用函数，数量很多，在此没有意义署名原作者，如果你是原创，请你原谅，反正这些代码都是取自本网站，是自愿公开的，况且本人也不是为了谋利，应该不存在侵权，只是阁下的辛劳没有得到受惠者的知晓，在此，深表歉意，特此申明。
因为，本帖太长，不能做一个帖子贴出，可能要作2—3个帖子，使用时放在一个模块中，以便使用。
特此告知。
代码如下：

Public Function 通译(isr As String, Lx As String, XL As Integer)
'参数说明:
'1、isr是英文单词或中文单词，是备查或待转字符、单词、句子等。
'2 、函数作用类型，有三类：英汉互译[HY]、英转汉[YZH]、汉转英[HZY]。
'3、XL是基于“YTH”和“HTY”两类的小类型，分三类：获取英文对应的中文单词[ZW]、获取音标[YB]、获取中文和音标[ZH]
Select Case Lx
   Case "HY"
         Select Case XL
               Case 1: 通译 = 有道互译(isr) '功能：可翻译长句子、段落等。
               Case 2: 通译 = 英汉词通(isr) '功能：实现非专业要求下的英汉词语互译。
         End Select
   Case "YZH"
         Select Case XL
               Case 1 ''获取中文意思，形式如：通译(isr,"YZH",1),预备获取中文长句子，如果不能则依次用几个函数去搜，避免搜空。
                     通译 = 英TO中(isr) '首先获长句子。
                     If VBA.Len(通译) = 0 Then '不行再用海词去搜汉语词语；' 从海词取词118词用时16秒，为此最快。
                        通译 = GetFrHC(isr, 1)
                     ElseIf VBA.Len(通译) = 0 Then '再不行用有道搜
                        通译 = GetFrYD(isr, 1)
                     ElseIf VBA.Len(通译) = 0 Then '确实不行接着用词霸搜
                        通译 = GetFrCB(isr, 1)
                     ElseIf VBA.Len(通译) = 0 Then '迫不得已最后用必应搜
                        通译 = GetFrBY(isr, 1)
                     End If
               Case 2 '获取英文音标，形式如：通译(isr,"YZH",2)。
                     通译 = GetFrHC(isr, 2) '用海词搜
                     If VBA.Len(通译) = 0 Then '有道搜
                        通译 = GetFrYD(isr, 2)
                     ElseIf VBA.Len(通译) = 0 Then '用词霸搜
                        通译 = GetFrCB(isr, 2)
                     ElseIf VBA.Len(通译) = 0 Then '用必应搜
                        通译 = GetFrBY(isr, 2)
                     End If
               Case 3 '综合获取汉语单词和英文音标信息，形式如：通译(isr,"YZH",3)。
                     通译 = GetFrHC(isr, 3) '用海词搜
                     If VBA.Len(通译) = 0 Then '有道搜
                        通译 = GetFrYD(isr, 3)
                     ElseIf VBA.Len(通译) = 0 Then '用词霸搜
                        通译 = GetFrCB(isr, 3)
                     ElseIf VBA.Len(通译) = 0 Then '用必应搜
                        通译 = GetFrBY(isr, 3)
                     End If
         End Select
      Case "HZY"
         '虚以待位，专门汉译英之类。形式如：通译(isr,"HZY",1)。

End Select
End Function
Public Function 有道互译(ByRef isr As String)
'http://club.excelhome.net/thread-1304497-1-1.html'renahu
'功能：能够翻译长句子、段落等。
Dim pd$, exp$, i%, j%
Set js = CreateObject("scriptcontrol") '
Set ms = CreateObject("msscriptcontrol.scriptcontrol")
ms.Language = "JavaScript"
js.Language = "jscript"
exp = ""
pd = "type=AUTO"
ssr = ms.Eval("encodeURI('" & Replace(isr, "'", "\'") & "');")
pd = pd & "&i=" & Replace(Replace(Replace(ssr, "%", "%C2%"), "%C2%E", "%C3%A"), "%C2%20", " ")
pd = pd & "&doctype=json"
url = "http://fanyi.youdao.com/translate?smartresult=dict&smartresult=rule&smartresult=ugc&sessionFrom=null"
With CreateObject("msxml2.xmlhttp")
      .Open "POST", url, False
      .setRequestHeader "Host", "fanyi.youdao.com"
      .setRequestHeader "Connection", "keep-alive"
      .setRequestHeader "Content-Length", "137"
      .setRequestHeader "Accept", "application/json, text/javascript, */*; q=0.01"
      .setRequestHeader "Origin", "http://fanyi.youdao.com"
      .setRequestHeader "X-Requested-With", "XMLHttpRequest"
      .setRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 6.1; WOW64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/41.0.2272.101 Safari/537.36"
      .setRequestHeader "Content-Type", "application/x-www-form-urlencoded; charset=UTF-8"
      .setRequestHeader "Referer", "http://fanyi.youdao.com/"
      .setRequestHeader "Accept-Encoding", "gzip, deflate"
      .setRequestHeader "Accept-Language", "zh-CN,zh;q=0.8"
      .send (pd)
      js.addcode "renahu=" & .responseText
      For j = 1 To js.Eval("renahu.translateResult[0].length")
         exp = exp & js.Eval("renahu.translateResult[0][" & j - 1 & "].tgt")
      Next
      有道互译 = exp
   End With
End Function
Public Function 英汉词通(rng As String)
'功能：实现非专业要求下的英汉词语互译。
Dim xml
Dim url$, EngSentence$
Set xml = CreateObject("MSXML2.XMLHTTP")
Set mssc = CreateObject("msscriptcontrol.scriptcontrol")
mssc.Language = "JavaScript"
mssr = mssc.Eval("encodeURIComponent('" & rng & "');")
'EngSentence = URLEncodePlus(rng.Text)
'url = "https://translate.google.cn/m?hl=en&sl=enN&tl=zh-CN&ie=UTF-8&prev=_m&q=" & EngSentence
'Debug.Print Asc(rng)
aasc = Asc(rng)
If aasc > 64 And aasc < 123 Then
      url = "https://translate.google.cn/m?hl=en&sl=enN&tl=zh-CN&ie=UTF-8&prev=_m&q=" & rng
Else
      url = "https://translate.google.cn/m?hl=en&sl=zh-CN&tl=enN&ie=UTF-8&prev=_m&q=" & mssr '& GetURL(rng)利用下面的自定义函数。
End If
With xml
   .Open "GET", url, False
   .send
   If InStr(.responseText, "<div dir=""ltr"" class=""t0"">") > 0 Then
         英汉词通 = Split(Split(.responseText, "<div dir=""ltr"" class=""t0"">")(1), "</div><")(0)
      End If
End With
End Function

weiyingde · 发表于 2020-2-13 20:58

接上，继续……
Public Function 英TO中(isr)
'http://club.excelhome.net/thread-1418560-1-1.html
'感谢Long_III原创，将其代码进行改造和缩减，代码虽然不多，功能不小，很好用。
'很好用,能将英文单词、句子翻译成中文。
Dim url$, EngSentence$, s1 As String
With CreateObject("MSXML2.ServerXMLHTTP.6.0")
      url = "http://fanyi.youdao.com/translate?&i=" & isr & "&doctype=xml&version"
      .Open "GET", url, False
      .send
      s = .responseText
      s0 = StrReverse(s)
      i1 = InStr(1, s0, "]]")
      i2 = InStr(1, s0, "[ATADC[")
      s1 = Mid(s, Len(s) - i2 + 2, i2 - i1 - 2)
      英TO中 = s1
End With
End Function
Public Function GetFrHC(tmpWord As String, Nuber As Integer)
'从海词取词118词用时16秒，为此最快。
On Error Resume Next
Dim str_base As String
If Len(tmpWord) = 0 Then Exit Function
url = "http://dict.cn/" & tmpWord
Debug.Print url
tmpTrans = ""
tmpPhonetic = ""
With CreateObject("Msxml2.ServerXMLHTTP")
      .Open "get", url, False 'True
      .send
      While .readyState <> 4
         DoEvents
      Wend
      str_base = .responseText
      Debug.Print str_base
      Open "C:\Users\Administrator\Desktop\testhaici.txt" For Output As #1
      Print #1, str_base
      Close #1
      '取得音标部分
      ybEN = "英 " & Split(Split(str_base, "EN-US"">")(1), "<")(0)
      ybUS = " 美 " & Split(Split(str_base, "EN-US"">")(2), "<")(0)
      tmpPhonetic = ybEN & " " & ybUS
      '取得中文含义部分
      t1 = Split(Split(str_base, "<ul class=""dict-basic-ul"">")(1), "<li style=""padding-top: 25px;"">")(0)
      t2 = Replace(t1, Chr(10), "")
      t3 = Replace(t2, "</strong>", "</strong>" & Chr(10))
      t4 = DelHtml(t3)
      tmpTrans = Mid(t4, 1, Len(t4) - 1)
      Select Case Nuber
            Case 1: GetFrHC = tmpTrans '获取中文词
            Case 2: GetFrHC = tmpPhonetic '获取英文的音标
            Case 3: GetFrHC = tmpTrans & vbCr & tmpPhonetic
      End Select
End With
End Function
Public Function GetFrYD(tmpWord As String, Nuber As Integer)
'http://dict.youdao.com/search?q=单词&keyfrom=dict.index
'有道取词118词,用时45秒。
Dim XH As Object
Dim s() As String
Dim str_tmp As String, url
Dim str_base As String
If Len(tmpWord) = 0 Then Exit Function
tmpTrans = ""
tmpPhonetic = ""
'开启网页
Set XH = CreateObject("Microsoft.XMLHTTP")
'‘ URL = "http://dict.youdao.com/search?q=" & tmpWord & "&keyfrom=dict.index"
url = "http://dict.youdao.com/search?q=" & tmpWord
On Error Resume Next
XH.Open "GET", url, False
XH.send
On Error Resume Next
str_base = XH.responseText
XH.Close
Set XH = Nothing
't1 = Split(str_base, "tic"">")
't2 = Split(str_base, "<ul>")
'取音标
ybEN = "英 " & Split(Split(str_base, "tic"">")(1), "<")(0)
ybUS = " 美 " & Split(Split(str_base, "tic"">")(2), "<")(0)
'取中文翻译
str_tmp = Split(Split(str_base, "<ul>")(1), "</ul>")(0)
s = Split(str_tmp, "<li>")
For i = LBound(s) + 1 To UBound(s)
      tmpTrans = tmpTrans & Chr(10) & Split(s(i), "</li")(0)
Next
tmpTrans = Mid(tmpTrans, 2)
tmpPhonetic = ybEN & ybUS
Select Case Nuber
         Case 1: GetFrYD = tmpTrans '获取中文词
         Case 2: GetFrYD = tmpPhonetic '获取英文的音标
         Case 3: GetFrYD = tmpTrans & vbCr & tmpPhonetic
End Select
End Function
Public Function GetFrCB(tmpWord As String, Nuber As Integer)
''从词霸取词，118词用时1分2秒。测试，有些词不能取出。
'"http://www.iciba.com/" & tmpWord
   Dim XH As Object
   Dim s() As String
   Dim str_tmp As String
   Dim str_base As String
   If Len(tmpWord) = 0 Then Exit Function
   tmpTrans = ""
   tmpPhonetic = ""
   Dim url As String
   tmpWord = Replace(tmpWord, " ", "_")
   url = "http://www.iciba.com/" & tmpWord
   '开启网页
   Set XH = CreateObject("Microsoft.XMLHTTP")
   On Error Resume Next
   XH.Open "get", url, 0 'True
   XH.send (Null)
   On Error Resume Next
   While XH.readyState <> 4
      DoEvents
   Wend
   str_base = XH.responseText
   XH.Close
   Set XH = Nothing
   '取得音标部分
   ybEN = "英 " & Split(Split(str_base, ">英 ")(1), "<")(0)
   ybUS = " 美 " & Split(Split(str_base, ">美 ")(1), "<")(0)
   tmpPhonetic = ybEN & ybUS
   '对中文含义分解
   hytmp = ""
   hy = Replace(Split(Split(str_base, "s="""">")(1), "</ul>")(0), "prop"">", ">" & Chr(10))
   hy = Split(hy, "<span")
   For i = LBound(hy) + 1 To UBound(hy)
      hytmp = hytmp & Split(Split(hy(i), ">")(1), "<")(0)  'vbCrLf &
   Next i
   tmpTrans = Mid(hytmp, 2)
' tmpTrans = DelHtml(hy)
Select Case Nuber
         Case 1: GetFrCB = tmpTrans '获取中文词
         Case 2: GetFrCB = tmpPhonetic '获取英文的音标
         Case 3: GetFrCB = tmpTrans & vbCr & tmpPhonetic
End Select
End Function

		自动登录	找回密码
密码			免费注册

[分享] 我的VBA自定义函数研习收获