ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

EH搜索     
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
Excel不给力? 何不试试FoxTable! Excel 2016函数公式学习大典 Office知识技巧免费学 打造核心竞争力的职场宝典
300集Office 2010微视频教程 Tableau-数据可视化工具 精品推荐-800套精选PPT模板,点击获取 ExcelHome出品 - VBA代码宝免费下载
你的Excel 2010实战技巧学习锦囊 欲罢不能, 过目难忘的 Office 新界面 Excel VBA经典代码实践指南
查看: 18999|回复: 507

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

  [复制链接]

TA的精华主题

TA的得分主题

发表于 2018-4-25 13:59 | 显示全部楼层 |阅读模式
看到有一朋友需要此函数,但是原来的帖子没找到,请朋友自己参考吧!
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

评分

参与人数 13财富 +30 鲜花 +24 收起 理由
1055751654 + 2 太强大了
深秋红叶2019 + 2 太强大了
liulang0808 + 10 值得肯定
xiaoyunyt + 2 值得肯定
xinyuan8751 + 2 值得肯定

查看全部评分

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财富 +10 鲜花 +13 收起 理由
达州张先生 + 3 值得肯定
深秋红叶2019 + 2 太强大了
liulang0808 + 10 值得肯定
不知道为什么 + 3
一把小刀闯天下 + 3 优秀作品

查看全部评分

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鲜花 +16 收起 理由
达州张先生 + 3 值得肯定
深秋红叶2019 + 2
不知道为什么 + 3 优秀作品
一把小刀闯天下 + 3 优秀作品
740688321 + 1 优秀作品

查看全部评分

TA的精华主题

TA的得分主题

 楼主| 发表于 2018-7-1 12:00 | 显示全部楼层
本帖最后由 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

评分

参与人数 4财富 +10 鲜花 +8 收起 理由
liulang0808 + 10 值得肯定
不知道为什么 + 3 优秀作品
一把小刀闯天下 + 3 优秀作品
xiangbaoan + 2 太强大了

查看全部评分

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鲜花 +11 收起 理由
不知道为什么 + 3 值得肯定
LSYYLW + 2 太强大了
xiangbaoan + 2 太强大了
tengyt + 2 优秀作品
YZC51 + 2 太强大了

查看全部评分

TA的精华主题

TA的得分主题

 楼主| 发表于 2018-7-1 13:31 | 显示全部楼层

TA的精华主题

TA的得分主题

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

评分

参与人数 4鲜花 +8 收起 理由
yylucke + 2 值得肯定
xiangbaoan + 2 优秀作品
WYS67 + 2
一把小刀闯天下 + 2 优秀作品

查看全部评分

TA的精华主题

TA的得分主题

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

评分

参与人数 1鲜花 +2 收起 理由
13782671637 + 2 太强大了

查看全部评分

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鲜花 +3 收起 理由
一把小刀闯天下 + 3 优秀作品

查看全部评分

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鲜花 +9 收起 理由
一把小刀闯天下 + 3 优秀作品
xiangbaoan + 2 太强大了
WYS67 + 2 太强大了
13782671637 + 2 太强大了

查看全部评分

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

本版积分规则

关注官方微信,每天学会一个新技能

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

GMT+8, 2020-9-23 23:16 , Processed in 0.058210 second(s), 11 queries , Gzip On, MemCache On.

Powered by Discuz! X3.4

© 1999-2021 Wooffice Inc.

   

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

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

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