自定义函数--提取单元格内多个被分开的数字

YZC51

看到有一朋友需要此函数，但是原来的帖子没找到，请朋友自己参考吧！
Function wei(t)
    With CreateObject("vbscript.regexp")
        .Pattern = "([1-9][0-9]*)(\.\d+)?"
        .Global = True
            Set mh = .Execute(t)
            str1 = ""
            For Each m In mh
                str1 = str1 & "," & m.Value
            Next
    End With
    wei = Mid(str1, 2)
End Function




补充内容 (2020-1-17 14:26):
1、267、268楼拼音首字母

补充内容 (2020-3-8 12:01):
模拟微软最新 Xlookup 函数 140楼

补充内容 (2020-3-23 10:18):
451楼 现金日记账-V5.1
452楼 自动下拉关联数据有效性

补充内容 (2020-3-25 16:30):
456楼 全自动银行日记账

YZC51

具有Split 功能的自定义函数
Function Splity(ByVal rng As String, Optional ByVal yrng As String = " ", Optional ByVal num As Integer = 0)
    rng = rng & yrng
    If num < 0 Then Splity = "": Exit Function
    Select Case num
        Case 0
            If InStr(rng, yrng) = 0 Then Splity = "": Exit Function
            Splity = Mid(rng, 1, InStr(rng, yrng) - 1)
        Case Else
            rng1 = Replace(rng, yrng, "", , num - 1)
            If InStr(rng1, yrng) < 1 Then Splity = "": Exit Function
            Splity = Mid(rng1, InStr(rng1, yrng) + Len(yrng))
    End Select
End Function

YZC51

十进制与任意进制互转

Function DEC2N(k, Optional x = 3) '十进制转任意进制
    Dim V, y, z, L,M
    y = Len(k)
    If y = 0 Then DEC2N = "": Exit Function
    If k = 0 Then M = 1 Else M = Log(k) / Log(x) + 1
    For i = 1 To M
        L = k Mod x
        V = IIf(L > 9, Chr(L + 55), L) & V
        k = k \ x
    Next
    DEC2N = V
End Function

Function UNDEC(k, Optional x = 3)                '任意进制转十进制
    Dim V, y, z, L
    y = Len(k)
    If y = 0 Then UNDEC = "": Exit Function
    For i = y To 1 Step -1
        z = z + 1
        L = Mid(k, z, 1)
        M = IIf(Asc(L) > 64, Asc(L) - 55, L) * x ^ (i - 1)
        V = M + V
    Next
    UNDEC = V
End Function

YZC51

'命理八字四柱函数
'Pi = 3.1415926535898
Function sizhu(birth As Date, Optional gs As Integer = 0) As String
    Dim LSJZ, SX
    LSJZ = Split("甲子 乙丑 丙寅 丁卯 戊辰 已巳 庚午 辛未 壬申 癸酉 甲戌 乙亥 " _
            & "丙子 丁丑 戊寅 已卯 庚辰 辛巳 壬午 癸未 甲申 乙酉 丙戌 丁亥 " _
            & "戊子 已丑 庚寅 辛卯 壬辰 癸巳 甲午 乙未 丙申 丁酉 戊戌 已亥 " _
            & "庚子 辛丑 壬寅 癸卯 甲辰 乙巳 丙午 丁未 戊申 已酉 庚戌 辛亥 " _
            & "壬子 癸丑 甲寅 乙卯 丙辰 丁巳 戊午 已未 庚申 辛酉 壬戌 癸亥 ")
    SX = "鼠牛虎兔龙蛇马羊猴鸡狗猪"
    If gs = 6 Then birth = birth + 22.999 / 24
'--------------------------------------------------------------------------------------------以上为变量定义
    yy = Year(birth): mm = Month(birth): dd = Day(birth): hh = Hour(birth)
'-------------------------------------------------------------------------------------------年柱已经调试好   '立春为年首
    yy1 = yy - 4
'    If Format(birth, "yyyymmddhhmmss") < Format(getjq(yy, 2, 4), "yyyymmddhhmmss") Then yy1 = yy1 - 1
    If Format(birth, "yyyymmdd") < Format(getjq(yy, 2, 4), "yyyymmdd") Then yy1 = yy1 - 1   '调整为按整日改变
    ncs = yy1 Mod 60
    nzhu = LSJZ(ncs)
'-------------------------------------------------------------------------------------------月柱已经调试好
    jieqi = getjq(yy, mm * 2 - 2, 4)
'    If Format(birth + 1 / 24, "yyyymmddhhmmss") < Format(jieqi, "yyyymmddhhmmss") Then mm = mm - 1
    If Format(birth + 1 / 24, "yyyymmdd") < Format(jieqi, "yyyymmdd") Then mm = mm - 1      '调整为按整日改变
    ycs = (mm + (yy Mod 5) * 12 + 12) Mod 60
    yzhu = LSJZ(ycs)
'-------------------------------------------------------------------------------------------日柱已经调试好
    rcs = (Int(birth) + 8 + IIf(hh < 23, 0, 1)) Mod 60
    rzhu = LSJZ(rcs)
'-------------------------------------------------------------------------------------------时柱已经调试好
    scs = (Int(birth) * 12 + 36 + hh / 2 + 1 / 24) Mod 60
    szhu = LSJZ(scs)
'-------------------------------------------------------------------------------------------结果输出
    sizhu = nzhu & "年 " & yzhu & "月 " & rzhu & "日 " & szhu & "时"
    sizhu = Choose(gs, nzhu, yzhu, rzhu, szhu, Mid(SX, (ncs Mod 12) + 1, 1), yzhu & "月" & rzhu & "日", nzhu & "年" & "【" & Mid(ShuX, ncs Mod 12 + 1, 1) & "】")
End Function

'24节气3.141592653589793238462643383279
下面是论坛大加的24节气函数，在此借用并致谢！
Function getjq(yy, mm, Optional gs As Integer = 0)              '经校对并测试1900-2100几无误差-yzc51
    jqmc = "小寒大寒立春雨水惊蛰春分清明谷雨立夏小满芒种夏至小暑大暑立秋处暑白露秋分寒露霜降立冬小雪大雪冬至"
    v0 = 628.3319653318
    t = 0                                                       '第1步迭代
    L0 = (48650621.66 + 6283319653.318 * t) / 10 ^ 7
    W = (mm - 5 + (yy - 1999) * 24) * 15 * 3.14159265358979 / 180         'W指的是太阳黄经。1999年春分对应W=0，
                                                                '以后每W每增加15度对应下一个节气。
    t = t + (W - L0) / v0                                       '第2步迭代
    t2 = t * t
    l1 = (48950621.66 + 6283319653.318 * t + 53 * t2 _
          + 334116 * Cos(4.67 + 628.307585 * t) + 2061 * Cos(2.678 + 628.3076 * t) * t) / 10 ^ 7
    v1 = 628.332 + 21 * Sin(1.527 + 628.307585 * t)
    t = t + (W - l1) / v1                                       '第3步迭代
    t2 = t * t
    t3 = t2 * t
    t4 = t3 * t
     L2 = (48950621.66 + 6283319653.318 * t + 52.9674 * t2 + 0.00432 * t3 - 0.001124 * t4 _
         + 334166 * Cos(4.669257 + 628.307585 * t) + 3489 * Cos(4.6261 + 1256.61517 * t) _
         + 350 * Cos(2.744 + 575.3385 * t) + 342 * Cos(2.829 + 0.3523 * t) _
         + 314 * Cos(3.628 + 7771.3771 * t) + 268 * Cos(4.418 + 786.0419 * t) _
         + 234 * Cos(6.135 + 393.021 * t) + 132 * Cos(0.742 + 1150.677 * t) _
         + 127 * Cos(2.037 + 52.9691 * t) + 120 * Cos(1.11 + 157.7344 * t) _
         + 99 * Cos(5.23 + 588.493 * t) + 90 * Cos(2.05 + 2.63 * t) _
         + 86 * Cos(3.51 + 39.815 * t) + 78 * Cos(1.18 + 522.369 * t) _
         + 75 * Cos(2.53 + 550.755 * t) + 51 * Cos(4.58 + 1884.923 * t) _
         + 49 * Cos(4.21 + 77.552 * t) + 36 * Cos(2.92 + 0.07 * t) _
         + 32 * Cos(5.85 + 1179.063 * t) + 28 * Cos(1.9 + 79.63 * t) _
         + 27 * Cos(0.31 + 1097.71 * t) + 2060.6 * Cos(2.67823 + 628.307585 * t) * t _
         + 43 * Cos(2.635 + 1256.6152 * t) * t + 8.72 * Cos(1.072 + 628.3076 * t) * t2 _
         - 994 - 834 * Sin(2.1824 - 33.75705 * t) _
         - 64 * Sin(3.5069 + 1256.66393 * t)) / 10 ^ 7

    t = t + (W - L2) / v1                                                   '第4步迭代
    J2000 = 2451545
   JD = J2000 + t * 36525 - (64.7 + (yy - 2005) * 0.4) / 86400 + 8 / 24     '地球自转修正项 需完善
  '   JD = J2000 + t * 36525 - deltaT(yy) / 86400 + 8 / 24                  '地球自转修正项 已完善
    Z = Int(JD + 0.5)                                                       '转换日期
    F = JD + 0.5 - Z
   
    a0 = Int((Z - 1867216.25) / 36524.25)
    A = Z + 1 + a0 - Int(a0 / 4): If Z < 2299161 Then A = Z
    B = A + 1524
    C = Int((B - 122.1) / 365.25)
    D = Int(365.25 * C)
    E = Int((B - D) / 30.6001)
    If yy = 1951 Then tm = -0.6 / 4320                      '以上两行代码用于修正为1951-12-23 的误差。已经校正1900-2100年的误差
    If yy = 2084 Then tm = 2.1 / 4320                       '以上两行代码用于修正为2084-03-19 的误差。已经校正1900-2100年的误差
    d1 = B - D - Int(30.6001 * E) + F - tm
'    d1 = B - d - Int(30.6001 * E) + F
    m1 = E - 13: If E < 14 Then m1 = E - 1
    y1 = C - 4715: If m1 > 2 Then y1 = C - 4716
    d2 = (d1 - Int(d1)) * 86400
    hh1 = Int(d2 / 3600)
    mm1 = Int(((d2 - hh1 * 3600) / 60))
    mm2 = ((d2 - hh1 * 3600) / 60)
    ss1 = Round((mm2 - mm1) * 60, 2)
   
    getjq1 = y1 & Format(m1, "\-00\-") & Format(Int(d1), "00")
    getjq2 = Format(hh1, " 00") & Format(mm1, "\:00") & Format(ss1, "\:00.00 ")
    getjq3 = Format(m1, "00\-") & Format(Int(d1), "00") & Format(hh1, " 00") & Format(mm1, "\:00")
   
    getjq = getjq1 & getjq2
   
    If gs = 1 Then getjq = getjq & Mid(jqmc, (mm Mod 24) * 2 + 1, 2)
    If gs = 2 Then getjq = Mid(jqmc, (mm Mod 24) * 2 + 1, 2)
    If gs = 3 Then getjq = getjq1
    If gs = 4 Then getjq = DateSerial(y1, m1, Int(d1)) + d2 / 86400
    If gs = 5 Then getjq = "今日" & Mid(jqmc, (mm Mod 24) * 2 + 1, 2) & Chr(10) & getjq3
   
'    Debug.Print getjq
End Function

一把小刀闯天下

'提取数字，可以在mark中加入"."

Option Explicit

Sub test()
  Dim s
  s = "1ewd212cdc23wee1frr44 1"
  MsgBox fc(s)
End Sub

Function fc(s)
  Dim i, j, n, mark
  mark = "0123456789"
  s = Trim(s): If Len(s) = 0 Then Exit Function
  ReDim arr(1 To Len(s))
  s = s & "#"
  For i = 1 To Len(s)
    If InStr(mark, Mid(s, i, 1)) Then
      n = n + 1
      For j = i To Len(s)
        If InStr(mark, Mid(s, j, 1)) = 0 Then
          arr(n) = Mid(s, i, j - i): i = j: Exit For
        End If
      Next
    End If
  Next
  If n > 0 Then ReDim Preserve arr(1 To n): fc = Join(arr, vbNewLine)
End Function

YZC51

太强大了。谢谢老师分享！

YZC51

自定义函数举例！
举例.rar (248.88 KB, 下载次数: 295)

2018-7-17 12:32 上传

点击文件名下载附件

YZC51

谢谢老师鼓励！
增加了由身份证编码提取出生日期函数
举例2.rar (366.81 KB, 下载次数: 200)

2018-7-17 14:45 上传

点击文件名下载附件

YZC51

Public Sub 隔行变颜色()
    Dim i As Integer
    Cells.Interior.ColorIndex = xlNone
    r = Cells(Rows.Count, 1).End(3).Row
    arr = Range("a1:a" & r)
    For i = 2 To r
        t = arr(i, 1): t1 = arr(i - 1, 1)
        If t1 <> t Then k = k + 1
        If k Mod 2 Then Rows(i).Interior.ColorIndex = 6
    Next i
End Sub

YZC51

Function DEC2N(k, Optional x = 3) '十进制转任意进制(yzc51原创),字符串最快
    Dim V, y, z, L, M
'    ar = Split("0 1 2 3 4 5 6 7 8 9 A B C D E F G H I J K L M N O P Q R S T U V W X Y Z")
    ar = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_`abcdefghijklmnopqrstuvwxyz{|}~"

    y = Len(k)
    If y = 0 Then DEC2N = "": Exit Function
    If k = 0 Then M = 1 Else M = Log(k) / Log(x) + 1
    For i = 1 To M
        L = k Mod x
'        V = Replace(IIf(L > 9, Chr(L + 55), L), "E", "é") & V"
'        V = IIf(L > 9, Chr(L + 55), L) ', "E", "ё") & V
        V = Mid(ar, L + 1, 1) & V
'       V = ar(L) & V
        k = k \ x
    Next
'    DEC2N = "'" & V
    DEC2N = V
End Function