有没有人共享自定义函数___类___等的?【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

获取文件路径，并放在指定的工作表和位置，最后的注释使用说明
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
END
Attribute VB_Name = "GetFilesPath"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Private m_WsA As Worksheet
Private m_DicA As New Dictionary, m_DicB As New Dictionary
Private m_ObjShell As Object, m_ObjFolder As Object
Private m_MyName, m_RowA, m_ColuA, m_Patch, m_Msg, m_R1, m_Keys, m_MyFileName, m_FileType
Private Sub Class_Initialize()
Set m_ObjShell = CreateObject("Shell.Application")
m_RowA = 1
m_ColuA = 1
m_R1 = 0
m_FileType = "*.xls*"
End Sub
Property Let WsName(WsName As String)
Set m_WsA = ThisWorkbook.Sheets(WsName)
End Property
Property Let StarRow(StarRow As Integer)
m_RowA = StarRow
End Property
Property Let StarColumn(StarColumn As Integer)
m_ColuA = StarColumn
End Property
Property Let FileType(FileType)
m_FileType = FileType
End Property
Public Function GetFiles()
Dim m_R1
If m_WsA Is Nothing Then
m_Msg = "没有找到清单表"
Call Erro
GoTo GotoEnd
End If
Set m_ObjFolder = m_ObjShell.BrowseForFolder(0, "选择文件夹", 0, 0)
If m_ObjFolder Is Nothing Then
GoTo GotoEnd
Else
m_Patch = m_ObjFolder.self.Path & "\"
End If
m_DicA.Add (m_Patch), ""
Do While m_R1 < m_DicA.Count
m_Keys = m_DicA.Keys '开始遍历字典
m_MyName = Dir(m_Keys(m_R1), vbDirectory) '查找目录
Do While m_MyName <> ""
If m_MyName <> "." And m_MyName <> ".." Then
On Error Resume Next
If (GetAttr(m_Keys(m_R1) & m_MyName) And vbDirectory) = vbDirectory Then '如果是次级目录
m_DicA.Add (m_Keys(m_R1) & m_MyName & "\"), "" '就往字典中添加这个次级目录名作为一个条目
End If
On Error GoTo -1
End If
m_MyName = Dir '继续遍历寻找
Loop
m_R1 = m_R1 + 1
Loop
If VBA.IsArray(m_FileType) Then
For Each m_Keys In m_DicA.Keys
For m_R1 = 0 To UBound(m_FileType)
m_MyFileName = Dir(m_Keys & m_FileType(m_R1), vbDirectory)
Do While m_MyFileName <> ""
m_DicB.Add (m_Keys & m_MyFileName), m_MyFileName
m_MyFileName = Dir
Loop
Next m_R1
Next m_Keys
Else
For Each m_Keys In m_DicA.Keys
m_MyFileName = Dir(m_Keys & m_FileType, vbDirectory)
Do While m_MyFileName <> ""
m_DicB.Add (m_Keys & m_MyFileName), m_MyFileName
m_MyFileName = Dir
Loop
Next m_Keys
End If
m_WsA.Cells(m_RowA, m_ColuA).Resize(m_DicB.Count, 1) = WorksheetFunction.Transpose(m_DicB.Items)
m_WsA.Cells(m_RowA, m_ColuA + 1).Resize(m_DicB.Count, 1) = WorksheetFunction.Transpose(m_DicB.Keys)
GotoEnd:
End Function
Private Sub Erro()
MsgBox m_Msg
End Sub
'With GetFilesPathA
' .WsName = WsD.Name
' .StarRow = 3
' .StarColumn = 2
' .GetFiles
'End With

ADO的类发不出来。。。被系统吃了，有需要的加我扣要吧

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

请问一下，函数和带参数的子过程的区别。网上查了资料，说是函数会返回值。带参数的子过程也会返回值吧？比如子过程接受一个数组参数，子过程给数组内部排序，最后这个排过序的数组就是返回的值吧？

日	一	二	三	四	五	六

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

扫二维码下载贴吧客户端