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

YZC51

单元格内词组排序

1. Public Sub main() '单元格内词组排序
   
2.     arr = Application.Transpose([a1:a20])
   
3.     For i = LBound(arr) To UBound(arr)
   
4.         ReDim barrel(0 To 99999) ' As String
   
5.         nums = Split(arr(i), ",")
   
6.         For j = LBound(nums) To UBound(nums)
   
7.             barrel(Abs(Asc(nums(j))) + j) = nums(j) & ","
   
8.         Next
   
9.         s = Join(Filter(barrel, ","), "")
   
10.         arr(i) = Left(s, Len(s) - 1)
    
11.     Next
    
12.     [a1].Resize(UBound(arr, 1)) = Application.Transpose(arr)
    
13. End Sub

复制代码

YZC51

注册程序（分享）
注册程序（分享）-1.rar (108.18 KB, 下载次数: 37)

2020-6-9 17:02 上传

点击文件名下载附件

YZC51

1. Function getCurrentTime() '北京时间
   
2.     With CreateObject("Microsoft.XMLHTTP")
   
3.         .Open "HEAD", "https://www.baidu.com/", False
   
4.         .send
   
5.         t = .getResponseHeader("Date")
   
6.     End With
   
7.     getCurrentTime = CDate(Mid$(t, 6, 20)) + 1 / 3
   
8. End Function
   
9. 
   
10. Function getUTCTime() 'UTC时间
    
11.     With CreateObject("Microsoft.XMLHTTP")
    
12.         .Open "HEAD", "https://www.baidu.com/", False
    
13.         .send
    
14.         t = .getResponseHeader("Date")
    
15.     End With
    
16.     getUTCTime = CDate(Mid$(t, 6, 20))
    
17. End Function
    
18. 
    
19. Function getTimeZone() '获取系统时区
    
20.     With CreateObject("Microsoft.XMLHTTP")
    
21.         .Open "HEAD", "https://www.baidu.com/", False
    
22.         .send
    
23.         t = .getResponseHeader("Date")
    
24.     End With
    
25.     TimeZone = (Now - CDate(Mid$(t, 6, 20))) * 24
    
26.     If TimeZone > 0 Then gs = "+0" Else gs = "0"
    
27.     getTimeZone = Format(TimeZone, gs)
    
28. End Function
    
29. 
    
30. Function 获取当前系统时区()
    
31.     Set js = CreateObject("msscriptcontrol.scriptcontrol")
    
32.     js.Language = "javascript"
    
33.     js.addcode "function GetDate(){var js = new Date().getTimezoneOffset();return js;}"
    
34.     获取当前系统时区 = js.eval("GetDate()") / 60
    
35. End Function

复制代码

YZC51

动态密码 动态密码-日期-时区.rar (20.97 KB, 下载次数: 24)

2020-6-12 22:42 上传

点击文件名下载附件

二维码-读写注册表.rar (114.06 KB, 下载次数: 30)

2020-6-12 22:41 上传

点击文件名下载附件

YZC51

不连续区域复制粘贴
http://club.excelhome.net/thread-1490501-3-1.html

1. ‘不连续多区域跨表同区域复制粘贴
   
2. Sub TEST()
   
3.     myADD = Selection.Address
   
4.     Cells(1, 1) = myADD
   
5.     arr = Split(myADD, ",")
   
6.     If UBound(arr) <> -1 Then
   
7.         For h = LBound(arr) To UBound(arr)
   
8.             Range(arr(h)).Copy Sheets(2).Range(arr(h))
   
9.         Next h
   
10.     End If
    
11. End Sub

复制代码

blackttea1

感谢楼主的分享！

YZC51

具有注册检查功能的多簿应用程序
具有注册检查功能的多簿应用程序-1.rar (188.59 KB, 下载次数: 24)

2020-6-13 21:09 上传

点击文件名下载附件

YZC51

学习蓝老师和赵老师的作品
四级下拉菜单
四级下拉菜单-学习蓝老师和赵老师的作品20200614.rar (55 KB, 下载次数: 25)

2020-6-14 18:08 上传

点击文件名下载附件

zq1210

谢谢老师分享，都是经典啊。

YZC51

添加模块

1. Sub 添加模块() '避免重名错误=简化
   
2.     Dim I As Long
   
3.     Dim S As String
   
4.     On Error Resume Next
   
5.     Do
   
6.         I = I + 1
   
7.         S = ThisWorkbook.VBProject.VBComponents("NewModel" & I).Name
   
8.     Loop Until Err
   
9.     ThisWorkbook.VBProject.VBComponents.Add(1).Name = "NewModel" & I
   
10. End Sub
    
11. 'ThisWorkbook.VBProject.VBComponents.Add(1).Name = "NewModel21" '  将标准模块添加到集合'好用
    
12. 'ThisWorkbook.VBProject.VBComponents.Add(2).Name = "NewModel21" '  将类模块添加到集合  '好用
    
13. 'ThisWorkbook.VBProject.VBComponents.Add(3).Name = "NewModel21" '  将窗体模块添加到集合 '好用

复制代码