有没有人共享自定义函数___类___等的?【vba吧】

如题,我先随便发几个,如果有人共享,那就一直更新.没有就算了.....

Function splitx(str, Optional fuhao) '分割后,返回结果为数组
'类似split,对str字符串进行分割,如省略fuhao参数,则按位分割.
'如splitx("abcd")结果为a,b,c,d这样的数组
'splitx("1+-++2---+3", "+-")结果为1,2,3
Dim ar, tsfuhao As String, arfh, p, w%, lenfh%
'tsfuhao = WorksheetFunction.Unichar(WorksheetFunction.Hex2Dec("07A00"))
tsfuhao = WorksheetFunction.Unichar(10025)
'上面是ascii码转成的特殊字符
ReDim ar(Len(str) - 1)
'splitx 与split类似,无fuhao参数时,将rng按个分解,有fuhao参数时,按符号分解,如splitx("1+-2-+3","+-")结果为[1,2,3]
If IsMissing(fuhao) Then
For i = 1 To Len(str)
ar(i - 1) = Mid(str, i, 1)
Next
splitx = ar
Exit Function
End If
lenfh = Len(fuhao)
ReDim arfh(lenfh - 1)
For w = 1 To lenfh
arfh(w - 1) = Mid(fuhao, w, 1)
Next
For Each p In arfh
str = WorksheetFunction.Substitute(str, p, tsfuhao)
Next
Do While InStr(str, tsfuhao & tsfuhao)
str = WorksheetFunction.Substitute(str, tsfuhao & tsfuhao, tsfuhao)
Loop
splitx = Split(str, tsfuhao)
End Function

splitx函数

Function fhstruniq(str) As String '文本去重返回去重后的文本
If Len(str) = 0 Then Exit Function
Dim ar, d As Object
ar = splitx(str)
Set d = CreateObject("scripting.dictionary")
For Each f In ar
d(f) = 1
Next
fhstruniq = VBA.Join(d.Keys, "")
End Function

Function arrmerge(ar1, ar2) '合并两个一维数组为一个
Dim arx1(), arx2(), m As Long, n As Long, g, p, i As Long, k As Long
m = UBound(ar1) - LBound(ar1) + 1
n = UBound(ar2) - LBound(ar2) + 1
ReDim arx1(LBound(ar1) To LBound(ar1) + m + n - 1)
arx1 = ar1
ReDim Preserve arx1(LBound(ar1) To LBound(ar1) + m + n - 1)
For Each g In ar2
arx1(m + LBound(ar1)) = g
m = m + 1
Next
Erase ar1, ar2 '擦除值或者释放内存,此处是否有必要?
ReDim arx2(UBound(arx1) - LBound(arx1))
For Each p In arx1
arx2(k) = p: k = k + 1
Next
arrmerge = arx2 '返回的数组下标从0开始
End Function
Sub 测试两数组合为一()
ar1 = [{1,2,3,4,5}]
Dim ar2(3 To 5)
ar2(3) = 6: ar2(4) = 7: ar2(5) = [{8,9,0}]
dd = arrmerge(ar1, ar2) ''' 结果为1,2,3,4,5,6,7,[8,9,0]这样的一维数组.
End Sub

Function fhdate(riqi) As Date '返回字符串组成的日期时间
'3.4 3-4 3:4 3/4 34
If Len(riqi) < 2 Then Exit Function
On Error GoTo dateerror:
Dim datex As Date, i%, f, k%, m%, tempx, kszf, riqix(), intd%, inty%
kszf = Trim(riqi) '记录初始日期字符,用于调整1998526.98516 13:15这样的格式
riqi = splitx(riqi, ".- /年月日")
If kszf = Trim(VBA.Join(riqi)) Then
ReDim riqix(2)
Select Case Len(kszf)
Case Is > 6
inty = 4
Case Is > 3
inty = 2
Case Is = 3
inty = 1
Case Else
Exit Function
End Select
intd = WorksheetFunction.RoundUp(((Len(kszf) - inty) / 2 - 0.01), 0)
riqix(1) = 99: riqix(2) = 3 '初始,随便设置一个大于12(月份)的数
Do Until Val(riqix(1)) <= 12 And Val(riqix(2)) < 32
riqix(0) = Left(kszf, inty) '年
riqix(1) = Mid(kszf, inty + 1, Len(kszf) - inty - intd) '月
riqix(2) = Right(kszf, intd) '日
inty = inty + 2
intd = WorksheetFunction.RoundUp(((Len(kszf) - inty) / 2 - 0.01), 0)
If Val(riqix(1)) <= 12 And Val(riqix(2)) < 32 Then Exit Do
Loop
If Len(riqix(1)) = 1 And Len(riqix(2)) = 1 And Len(riqix(0)) = 1 Then riqix(1) = riqix(1) & riqix(2): riqix(2) = ""
fhdate = VBA.Format(VBA.Join(riqix, " "), "yyyy年mm月dd日 hh时mm分ss秒"): Exit Function
End If
fhdate = VBA.Format(VBA.Join(riqi, " "), "yyyy年mm月dd日 hh时mm分ss秒"): Exit Function
dateerror: '日期格式错误,下面清除错误并纠正日期
Err.Clear
For i = 0 To UBound(riqi)
If Not InStr(riqi(i), ":") And Len(riqi(i)) < 3 And riqi(i) > 12 Then
k = i
ElseIf Not InStr(riqi(i), ":") And Len(riqi(i)) < 3 And riqi(i) < 32 Then
m = i
End If
Next
tempx = riqi(m): riqi(m) = riqi(k): riqi(k) = tempx
fhdate = VBA.Format(VBA.Join(riqi, " "), "yyyy年mm月dd日 hh时mm分ss秒")
End Function

Function hqallfile(pathm, Optional fhlx$) '获取指定文件夹中的所有文件(数组),第二参数为指定的类型
On Error Resume Next
'Dim r() As Folder, fso As FileSystemObject, ar() As Folder, i%
Dim r() As Object, fso As Object, ar() As Object, i%, x%, p, arfilex()
If IsMissing(fhlx) Then fhlx = "*"
'如果上面fso之类的,不是定义为object,则属于前期绑定,需要在工具--'引用--勾选(microsoft scripting runtime)
'如果fso之类定义为object,则属于后期绑定,无须勾选(microsoft scripting runtime).
'前期绑定的好处是相关代码会有提示':::后期绑定的好处是,移植性高,因为无须勾选相关引用.
Dim f, g, y%, oi%, arfile(), arls
ReDim r(0)
'Dim pathm$,pathm是路径
Set fso = CreateObject("scripting.filesystemobject")
Set r(0) = fso.GetFolder(pathm)
'r()数组,ar()用来存放每一级的文件夹对象集合
Do
For y = 0 To UBound(r)
For Each f In r(y).SubFolders
ReDim Preserve ar(i)
Set ar(i) = f
i = i + 1
Next f
For Each g In r(y).Files
ReDim Preserve arfile(oi)
Set arfile(oi) = g
oi = oi + 1
Next g
Next y
ReDim r(i - 1)
r = ar
syfld = i: i = 0
'syfld是每级文件夹剩余数，为0时退出循环
Loop While syfld <> 0
x = 0
For Each p In arfile
arls = Split(p.Name, ".")
If arls(UBound(arls)) Like Trim(fhlx) Then
ReDim Preserve arfilex(x)
Set arfilex(x) = p: x = x + 1
End If
Next
hqallfile = arfilex
End Function
Sub 批量改sheet名()
On Error Resume Next
Dim allwb, pathname, wbobj, xlapp As New Excel.Application, sheetname$
sheetname = InputBox("第一步,先输入你想改为什么表名,第二步则是选择相应文件夹", "第一步:表名")
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show = -1 Then
pathname = .SelectedItems(1)
End If
End With
allwb = hqallfile(pathname, "*xl*")
For Each f In allwb
Set wbobj = xlapp.Workbooks.Open(f)
wbobj.Sheets(1).Name = sheetname
wbobj.Close True
DoEvents
Set wbobj = Nothing
Next
xlapp.Quit
End Sub

日	一	二	三	四	五	六

有没有人共享自定义函数_类_等的?

扫二维码下载贴吧客户端