曼城足球论坛技术论坛

找回密码
收费注册

QQ登录

只需一步,快速劈头

EH搜索
EH技术汇-专业的职场时间充电站 妙哉!函数段子手趣味讲函数 足球任事器-会足球,做管理系统 足球 Home精品图文教程库
足球不给力? 何不试试FoxTable! 足球 2016函数公式学习大典 Office常识技巧收费学 制造主旨竞争力的职场宝典
Tableau-数据可视化工具 曼城足球论坛出品 - VBA代码宝收费下载
你的足球 2010实战技巧学习锦囊 不能自休, 过目难忘的 Office 新界面 足球 VBA典范代码实践指南
审查: 17663 | 回复: 505
打印 上一主题 下一主题

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

[复制链接]

TA的精华主题

TA的得分主题

跳转到指定楼层
1
宣告于 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的得分主题

2
楼主 | 宣告于 2018-4-25 14:10 | 只看该作者
具有Split 效用的自定义函数
Function Splity(ByVal rng As String, Optional ByVal yrng As String = " ",足球吧论坛。 Optional ByVal num As Integer = 0),http://www.qhdjinxiu.com
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,足球VBA措施拓荒。 yrng) + Len(yrng))
End Select
End Function


评分

参与人数 6 财富 +10 鲜花 +13 收起 理由
达州张先生 + 3 值得确定
深秋红叶2019 + 2 太强大了
liulang0808 + 10 值得确定
不分明为什么 + 3
一把小刀闯天下 + 3 优秀作品

审查全部评分

TA的精华主题

TA的得分主题

3
楼主 | 宣告于 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的得分主题

4
楼主 | 宣告于 2018-7-1 12:00 | 只看该作者
本帖末了由 YZC51 于 2018-7-3 11:06 编辑

'命理八字四柱函数
'Pi = 3.
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,足球。
'--------------------------------------------------------------------------------------------以上为变量定义,vba。
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,足球VBA措施拓荒。 "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.
下面是论坛大加的24节气函数。
Function getjq(yy, mm, Optional gs As Integer = 0) '经校对并测试1900-2100几无误差-yzc51
jqmc = "小寒大寒立春雨水惊蛰春分清明谷雨立夏小满芒种夏至小暑大暑立秋处暑白露秋分寒露霜降立冬小雪大雪冬至"
v0 = 628.
t = 0 '第1步迭代
L0 = (.66 +.318 * t) / 10 ^ 7
W = (mm - 5 + (yy - 1999) * 24) * 15 * 3. / 180 'W指的是太阳黄经。1999年春分对应W=0,
'以后每W每增加15度对应下一个节气。
t = t + (W - L0) / v0 '第2步迭代
t2 = t * t
l1 = (.66 +.318 * t + 53 * t2 _
+ * Cos(4.67 + 628. * t) + 2061 * Cos(2.678 + 628.3076 * t) * t) / 10 ^ 7
v1 = 628.332 + 21 * Sin(1.527 + 628. * t)
t = t + (W - l1) / v1 '第3步迭代
t2 = t * t
t3 = t2 * t
t4 = t3 * t
L2 = (.66 +.318 * t + 52.9674 * t2 + 0.00432 * t3 - 0.001124 * t4 _
+ * Cos(4. + 628. * t) + 3489 * Cos(4.6261 + 1256. * 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. + 628. * 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. * t) _
- 64 * Sin(3.5069 + 1256. * t)) / 10 ^ 7

t = t + (W - L2) / v1 '第4步迭代
J2000 =
JD = J2000 + t * - (64.7 + (yy - 2005) * 0.4) / + 8 / 24 '地球自转修正项 需完善
' JD = J2000 + t * - deltaT(yy) / + 8 / 24 '地球自转修正项 已完善
Z = Int(JD + 0.5) '转换日期
F = JD + 0.5 - Z

a0 = Int((Z -.25) /.25)
A = Z + 1 + a0 - Int(a0 / 4): If Z < 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)) *
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 /
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的得分主题

5
宣告于 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 = "0"
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的得分主题

6
楼主 | 宣告于 2018-7-1 13:31 | 只看该作者
太强大了。谢谢教练分享!

TA的精华主题

TA的得分主题

7
楼主 | 宣告于 2018-7-17 12:32 | 只看该作者
自定义函数举例!
举例.rar (248.88 KB, 下载次数: 208)

评分

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

审查全部评分

TA的精华主题

TA的得分主题

8
楼主 | 宣告于 2018-7-17 14:45 | 只看该作者
谢谢教练促进!
增加了由身份证编码提取降生日期函数
举例2.rar (366.81 KB, 下载次数: 147)

评分

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

审查全部评分

TA的精华主题

TA的得分主题

9
楼主 | 宣告于 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的得分主题

10
楼主 | 宣告于 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 = "0ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_`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 太强大了

审查全部评分

您需要登录后才能够回帖 登录 | 收费注册

本版积分规则

存眷官方微信,高效办公专列,每天发车

手机版|关于我们|接洽我们|曼城足球论坛

GMT+8, 2020-9-13 04:03, Processed in 0.0 second(s), 14 queries , Gzip On, MemCache On.

Powered by Discuz! X3.4

? 1999-2021 Wooffice Inc.

沪公网安备号 沪ICP备号

本论坛言论纯属宣告者私人意见,任何违反国度相关法律的言论。

快速回复 前往顶部 前往列表