求助！红包求助！VBA提取文件导出

972475452

我需要做一EXCEL，能通过VBA批量读取文件名，并按格式导出文件。具体见附件谢谢大神。个人QQ：290653033。红包酬谢！！

鄂龙蒙

TEST FILE.rar (43.41 KB, 下载次数: 9)

2019-9-2 20:03 上传

点击文件名下载附件

鄂龙蒙

1. Function GetAllPath(Path$, Optional FileType$ = "*", _
   
2.     Optional FullName As Boolean = True, Optional IsFolder As Boolean = False)
   
3.     Dim dic As Object, i&, Fso As Object, Folder As Object
   
4.     Set dic = CreateObject("Scripting.Dictionary")
   
5.     Set Fso = CreateObject("Scripting.FileSystemObject")
   
6.     Set Folder = Fso.GetFolder(Path)
   
7.     i = 1
   
8.     Call GetPath(Folder, dic, FileType, IsFolder)
   
9.     If FullName Then GetAllPath = dic.keys Else: GetAllPath = dic.items
   
10.     Set Folder = Nothing: Set Fso = Nothing
    
11. End Function
    
12. Private Sub GetPath(ByVal Folder As Object, dic, Optional FileType$ = "*", Optional ByVal IsFolder As Boolean = False)
    
13.     Dim SubFolder As Object
    
14.     Dim File As Object, i&, arr
    
15.     If IsFolder Then
    
16.         For Each SubFolder In Folder.SubFolders
    
17.             If FileSerch(FileType, SubFolder.Name) Then dic.Add SubFolder.Path, SubFolder.Name
    
18.             Call GetPath(SubFolder, dic, FileType, IsFolder)
    
19.         Next
    
20.     Else
    
21.         For Each File In Folder.Files
    
22.             If FileSerch(FileType, File.Name) Then dic.Add File.Path & "" & File.Name, File.Name
    
23.         Next
    
24.         For Each SubFolder In Folder.SubFolders
    
25.             Call GetPath(SubFolder, dic, FileType, IsFolder)
    
26.         Next
    
27.     End If
    
28. End Sub
    
29. Private Function FileSerch(FileType$, fname$) As Boolean
    
30.     Dim arr, i&
    
31.     arr = Split(FileType, "|")
    
32.     For i = 0 To UBound(arr)
    
33.         If fname Like arr(i) Then FileSerch = True: Exit Function
    
34.     Next
    
35. End Function
    
36. Public Sub GetPathToRng(rng As Range, Path$, Optional FileType$ = "*", _
    
37.     Optional FullName As Boolean = True, Optional IsFolder As Boolean = False)
    
38.     Dim arr
    
39.     arr = GetAllPath(Path, FileType, FullName, IsFolder)
    
40.     rng.Resize(UBound(arr) + 1) = Application.Transpose(arr)
    
41. End Sub
    
42. Public Sub rngtest()
    
43.     [A3:E65536] = ""
    
44.     GetPathToRng [B3], ThisWorkbook.Path, , False, True
    
45.     a = [B65536].End(3).Row + 1
    
46.     GetPathToRng Range("B" & a), ThisWorkbook.Path, , False
    
47. End Sub

复制代码