关于自定义函数的使用理解及函数集锦

opiona

函数_获取文件夹文件和文件夹清单.rar (1.91 KB, 下载次数: 185)

2016-5-24 16:08 上传

点击文件名下载附件

1. 
   
2. '*********************************
   
3. '*******  北极狐工作室出品  ******
   
4. '*******  QQ：14885553      ******
   
5. '*********************************
   
6. 
   
7. Sub Opiona()
   
8. 
   
9. 'On Error Resume Next    '// 发生错误，自动执行下一句，就是忽略错误
   
10. Application.ScreenUpdating = False '//关闭屏幕刷新
    
11. Application.DisplayAlerts = False '//关闭系统提示
    
12. t = Timer   '//开始时间
    
13. 
    
14.     Set SH0 = Sheets("Sheet1")
    
15.     SH0.Range("A2:Z65536").ClearContents
    
16.    
    
17.     FileArr = FileAllArr(ThisWorkbook.Path, "*.xls?", ThisWorkbook.Name, True, False)
    
18.     For i = 0 To UBound(FileArr)
    
19.    
    
20.         msgbox GetPathFromFileName(FileArr(i))
    
21.    
    
22.     Next i
    
23. 
    
24. Application.ScreenUpdating = True '//恢复屏幕刷新
    
25. Application.DisplayAlerts = True '//恢复系统提示
    
26. MsgBox "一共用时：" & Format(Timer - t, "#0.0000") & " 秒", , "北极狐提示!!"  '//提示所用时间
    
27. End Sub
    
28. 
    
29. 
    
30. 
    
31. '*******************************************************************************************************
    
32. '功能：    查找指定文件夹含子文件夹内所有文件名或文件夹名（含路径）
    
33. '函数名：  FileAllArr
    
34. '参数1：   Filename    需查找的文件夹名，不包含文件名
    
35. '参数2：   FileFilter  需要过滤的文件名，可省略，默认为：[*.*]
    
36. '参数3：   Liwai       剔除例外的文件名，可省略，默认为：空，一般为：ThisWorkbook.Name
    
37. '参数4：   SubFiles    是否需要查找子文件夹内文件，可省略，默认为：true
    
38. '参数5：   Files       是否只要文件夹名，可省略，默认为：FALSE
    
39. '返回值：  一个字符型的数组
    
40. '使用方法：FileArr = FileAllArr(ThisWorkbook.Path, "*.xls", ThisWorkbook.Name,false,false)
    
41. '作者:    北极狐工作室 QQ：14885553
    
42. '*******************************************************************************************************
    
43. Public Function FileAllArr(ByVal Filename As String, Optional ByVal FileFilter As String = "*.*", Optional ByVal Liwai As String = "", Optional ByVal SubFiles As Boolean = True, Optional ByVal Files As Boolean = False) As String()
    
44.    
    
45.     Dim DIC, DID, Ke, MyName, MyFileName
    
46.     Dim I As Integer
    
47.    
    
48.     Set DIC = CreateObject("Scripting.Dictionary")    '创建一个字典对象
    
49.     Set DID = CreateObject("Scripting.Dictionary")
    
50.    
    
51.     Filename = Replace(Replace(Filename & "", "\", ""), "\", "")
    
52.     DIC.Add (Filename), ""
    
53.     I = 0
    
54.     Do While I < DIC.Count
    
55.         Ke = DIC.keys   '开始遍历字典
    
56.         If SubFiles = True Then  '//如果需要查找子文件夹
    
57.             MyName = Dir(Ke(I), vbDirectory)    '查找目录
    
58.             Do While MyName <> ""
    
59.                 If MyName <> "." And MyName <> ".." Then
    
60.                     If (GetAttr(Ke(I) & MyName) And vbDirectory) = vbDirectory Then    '如果是次级目录
    
61.                         DIC.Add (Ke(I) & MyName & ""), ""  '就往字典中添加这个次级目录名作为一个条目
    
62.                     End If
    
63.                 End If
    
64.                 MyName = Dir    '继续遍历寻找
    
65.             Loop
    
66.         End If
    
67.         I = I + 1
    
68.     Loop
    
69.     Dim arrx() As String
    
70.     I = 0
    
71.     If Files = True Then   '//是否只输出文件夹名
    
72.       
    
73.         For Each Ke In DIC.keys '以查找总表所在文件夹下所有excel文件为例
    
74.             ReDim Preserve arrx(I)
    
75.             If Ke <> Filename Then   '//自身文件夹除外
    
76.                 arrx(I) = Ke
    
77.                 I = I + 1
    
78.             End If
    
79.          Next
    
80.          FileAllArr = arrx
    
81.     Else
    
82.         For Each Ke In DIC.keys '以查找总表所在文件夹下所有excel文件为例
    
83.             MyFileName = Dir(Ke & FileFilter) '过滤器：EXCEL2003为：*.xls,excel2007为：*.xlsx
    
84.             Do While MyFileName <> ""
    
85.                If MyFileName <> Liwai Then '排除例外文件
    
86.                   ReDim Preserve arrx(I)
    
87.                   arrx(I) = Ke & MyFileName
    
88.                   I = I + 1
    
89.                End If
    
90.                 MyFileName = Dir
    
91.             Loop
    
92.         Next
    
93.         FileAllArr = arrx
    
94.     End If
    
95. End Function
    
96. 
    
97. 
    
98. '*'****************************************************************************************************
    
99. '函数:   GetPathFromFileName   根据全路径获得文件名
    
100. '参数1： strFullPath  完整路径
     
101. '参数2： kzm  true 返回字符串含扩展名,默认是：False
     
102. '参数3： strSplitor  各级文件夹分隔符
     
103. '作用:  从完整路径获取返回:  文件名(true带扩展名)
     
104. '使用方法:  msgbox GetPathFromFileName("C:\windows\text.txt",true)
     
105. '作者:    北极狐工作室 QQ：14885553
     
106. '*'****************************************************************************************************
     
107. Public Function GetPathFromFileName(ByVal strFullPath As String, Optional ByVal kzm As Boolean = False, Optional ByVal strSplitor As String = "") As String
     
108.     Dim FileName1 As String
     
109.     Dim FNAME As String
     
110.     FileName1 = Left$(strFullPath, InStrRev(strFullPath, strSplitor, , vbTextCompare))
     
111.     FileName1 = Replace(strFullPath, FileName1, "")
     
112.     If kzm = False Then
     
113.         GetPathFromFileName = Left(FileName1, InStrRev(FileName1, ".") - 1)
     
114.     Else
     
115.         GetPathFromFileName = FileName1
     
116.     End If
     
117. End Function
     
118. 
     
119. 
     
120. 
     
121. 
     

复制代码

opiona

baigangliao 发表于 2017-6-5 22:51
大师帮忙你好修改一下自定义函数

没明白你要实现什么！

why3791

大师请帮个忙，弄了一个多月了没弄好，怎样将代码变为自定义函数，因为经常用到，谢谢

why3791

附件没法上传
Sub 多条件不重复计数()
     Dim arr, d As Object, i, s%
   Set d = CreateObject("scripting.dictionary")
   arr = range("a2").CurrentRegion
   For i = 2 To UBound(arr)
   If VBA.Year(arr(i, 2)) = "2016" And arr(i, 8) = "特惠贷（精准扶贫）" Then
   If arr(i, 7) = "次级" Or arr(i, 7) = "可疑" Then
     d(arr(i, 6)) = ""
   End If
   End If
   Next
  [k1] = d.Count
End Sub

opiona

why3791 发表于 2017-11-23 20:41
附件没法上传
Sub 多条件不重复计数()
     Dim arr, d As Object, i, s%

1. Sub 多条件不重复计数()
   
2.    
   
3.     Dim I As Long
   
4.     I = GETNOTWO(Range("A2"))
   
5. End Sub
   
6. 
   
7. 
   
8. Public Function GETNOTWO(ByVal RNG As Range) As Long
   
9.    
   
10.     Dim ARR
    
11.     Dim CD As Object
    
12.     Dim I As Long
    
13.     Dim S As String
    
14.     Dim STR_1, STR_2, STR_3, STR_4 As String
    
15.    
    
16.     STR_1 = "2016"
    
17.     STR_2 = "特惠贷（精准扶贫）"
    
18.     STR_3 = "次级"
    
19.     STR_4 = "可疑"
    
20.    
    
21.     Set CD = CreateObject("scripting.dictionary")
    
22.     ARR = RNG.CurrentRegion
    
23.     For I = 2 To UBound(ARR)
    
24.         If VBA.Year(ARR(I, 2)) = STR_1 And ARR(I, 8) = STR_2 Then
    
25.             If ARR(I, 7) = STR_3 Or ARR(I, 7) = STR_4 Then
    
26.                 CD(ARR(I, 6)) = ""
    
27.             End If
    
28.         End If
    
29.     Next
    
30.     GETNOTWO = CD.Count
    
31. End Function

复制代码

寒潮大冬瓜

老师这个叫做金额中文大写！=328.10343<叁佰贰拾捌点壹零叁肆叁>这个方式是否应叫中文大写