ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

搜索
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 效率神器,一键搞定繁琐工作
HR薪酬管理数字化实战 Excel 2021函数公式学习大典 Excel数据透视表实战秘技 打造核心竞争力的职场宝典
让更多数据处理,一键完成 数据工作者的案头书 免费直播课集锦 ExcelHome出品 - VBA代码宝免费下载
用ChatGPT与VBA一键搞定Excel WPS表格从入门到精通 Excel VBA经典代码实践指南
查看: 137641|回复: 522

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

  [复制链接]

TA的精华主题

TA的得分主题

发表于 2018-4-25 13:59 | 显示全部楼层 |阅读模式
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
看到有一朋友需要此函数,但是原来的帖子没找到,请朋友自己参考吧!
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楼 全自动银行日记账

点评

代码集成贴,值得收藏  发表于 2020-9-10 17:30

评分

15

查看全部评分

TA的精华主题

TA的得分主题

 楼主| 发表于 2018-4-25 14:10 | 显示全部楼层
具有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


评分

6

查看全部评分

TA的精华主题

TA的得分主题

 楼主| 发表于 2018-7-1 11:56 | 显示全部楼层
本帖最后由 YZC51 于 2018-7-1 17:02 编辑

十进制与任意进制互转

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


评分

7

查看全部评分

TA的精华主题

TA的得分主题

 楼主| 发表于 2018-7-1 12:00 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
本帖最后由 YZC51 于 2018-7-3 11:06 编辑

'命理八字四柱函数
'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

评分

5

查看全部评分

TA的精华主题

TA的得分主题

发表于 2018-7-1 12:19 | 显示全部楼层
'提取数字,可以在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

评分

5

查看全部评分

TA的精华主题

TA的得分主题

 楼主| 发表于 2018-7-1 13:31 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
太强大了。谢谢老师分享!

TA的精华主题

TA的得分主题

 楼主| 发表于 2018-7-17 12:32 | 显示全部楼层
自定义函数举例!
举例.rar (248.88 KB, 下载次数: 297)

评分

4

查看全部评分

TA的精华主题

TA的得分主题

 楼主| 发表于 2018-7-17 14:45 | 显示全部楼层
谢谢老师鼓励!
增加了由身份证编码提取出生日期函数
举例2.rar (366.81 KB, 下载次数: 201)

评分

1

查看全部评分

TA的精华主题

TA的得分主题

 楼主| 发表于 2018-7-20 19:49 | 显示全部楼层
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

评分

1

查看全部评分

TA的精华主题

TA的得分主题

 楼主| 发表于 2018-7-22 21:01 | 显示全部楼层
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

评分

4

查看全部评分

您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

关闭

最新热点上一条 /1 下一条

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2024-12-24 11:34 , Processed in 0.042436 second(s), 12 queries , Gzip On, MemCache On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

沪公网安备 31011702000001号 沪ICP备11019229号-2

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:李志群律师

快速回复 返回顶部 返回列表