'获取目录中的文件、文件夹名称：将代码复制到任意excel执行（非SearchPath）
'使用前请修改SearchPath为实际路径
Sub search_name()
Const SearchPath = "C:\Users\lum15\Desktop\脚本"
Dim DicList, FileList, I
Dim Num As Long
Num = 1
AWbName = ActiveWorkbook.Name
'标题
Workbooks(AWbName).ActiveSheet.Cells(1, 1) = "序号"
Workbooks(AWbName).ActiveSheet.Cells(1, 2) = "名称"
Workbooks(AWbName).ActiveSheet.Cells(1, 3) = "类型"
Workbooks(AWbName).ActiveSheet.Cells(1, 4) = "父目录"
Set DicList = CreateObject("Scripting.Dictionary")
Set FileList = CreateObject("Scripting.Dictionary")
DicList.Add SearchPath, "" '初始化目录
'**************遍历所有目录*******************
I = 0
Do While I < DicList.Count
Key = DicList.Keys '本次要遍历的目录
NowDic = Dir(Key(I) & "\" & "*", vbDirectory) '开始查找
Do While NowDic <> ""
If (NowDic <> ".") And (NowDic <> "..") Then
If GetAttr(Key(I) & "\" & NowDic) = 16 Then '找到子目录，则添加
DicList.Add Key(I) & "\" & NowDic, ""
Num = Num + 1
Workbooks(AWbName).ActiveSheet.Cells(Num, 1) = Num - 1
Workbooks(AWbName).ActiveSheet.Cells(Num, 2) = NowDic
Workbooks(AWbName).ActiveSheet.Cells(Num, 3) = "文件夹"
Workbooks(AWbName).ActiveSheet.Cells(Num, 4) = Key(I)
End If
End If
NowDic = Dir() '再找
Loop
I = I + 1
Loop
'****************************************************
'**************遍历目录中的所有文件*******************
For Each Key In DicList.Keys '查找所有目录中的文件
NowFile = Dir(Key & "\" & "*")
Do While NowFile <> ""
Num = Num + 1
Workbooks(AWbName).ActiveSheet.Cells(Num, 1) = Num - 1
Workbooks(AWbName).ActiveSheet.Cells(Num, 2) = NowFile
Workbooks(AWbName).ActiveSheet.Cells(Num, 3) = "文件"
Workbooks(AWbName).ActiveSheet.Cells(Num, 4) = Key
NowFile = Dir()
Loop
Next
'****************************************************
Range("B1").Select
MsgBox "共获取" & Num & "个名称。"
End Sub
'合并指定目录下excel文件，第一个sheet内容：将代码复制到任意excel执行
'使用前请修改SearchPath为实际路径
Sub merge_excel()
Const SearchPath = "C:\Users\lum15\Desktop\脚本"
Dim MyName, AWbName
Dim Wb As Workbook, WbN As String
Dim G As Long
Dim Num As Long
Dim BOX As String
Application.ScreenUpdating = False
MyName = Dir(SearchPath & "\" & "*.xls*")
AWbName = ActiveWorkbook.Name
Num = 0
Do While MyName <> ""
If MyName <> AWbName Then
Set Wb = Workbooks.Open(SearchPath & "\" & MyName)
Num = Num + 1
With Workbooks(AWbName).ActiveSheet.Cells(.Range("B65536").End(xlUp).Row + 2, 1) = Left(MyName, Len(MyName) - 4)
For G = 1 To Sheets.Count
Wb.Sheets(G).UsedRange.Copy .Cells(.Range("B65536").End(xlUp).Row + 1, 1)
Next
WbN = WbN & Chr(13) & Wb.Name
Wb.Close False
End With
End If
MyName = Dir
Loop
Range("B1").Select
Application.ScreenUpdating = True
MsgBox "共合并了" & Num & "个excel。"
End Sub
'按excel内容整理文件夹内容：将代码复制到包含需要整理文件信息的excel执行
'使用前请修改SearchPath为实际路径
Sub collect()
Const SearchPath = "D:\lum15\PycharmProjects\金票\Temp"
Dim fs, MyName, AWbName
Set fs = CreateObject("scripting.filesystemobject")
Num = 1
RDir = "jp"
Col = 1
If fs.FolderExists(RDir) Then
fs.DeleteFolder (RDir)
End If
fs.CreateFolder (RDir)
AWbName = ActiveWorkbook.Name
Do While Num < Range("A65536").End(3).Row + 1
MyName = Dir(SearchPath & "\" & "*")
TName = Workbooks(AWbName).ActiveSheet.Cells(Num, Col)
TPath = RDir & "\" & TName
fs.CreateFolder (TPath)
Do While MyName <> ""
If MyName Like "*" & TName & "*" Then
fs.CopyFile SearchPath & "\" & MyName, TPath & "\" & MyName
End If
MyName = Dir
Loop
Num = Num + 1
Loop
MsgBox "结果文件夹" & RDir
End Sub