'獲取目錄中的文件、文件夾名稱：將代碼復(fù)制到任意excel執(zhí)行（非SearchPath）
'使用前請(qǐng)修改SearchPath為實(shí)際路徑
Sub search_name()
? ? Const SearchPath = "C:\Users\lum15\Desktop\腳本"
? ? Dim DicList, FileList, I
? ? Dim Num As Long
? ? Num = 1
? ? AWbName = ActiveWorkbook.Name
? ? '標(biāo)題
? ? Workbooks(AWbName).ActiveSheet.Cells(1, 1) = "序號(hào)"
? ? 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 & "個(gè)名稱。"
End Sub
'合并指定目錄下excel文件，第一個(gè)sheet內(nèi)容：將代碼復(fù)制到任意excel執(zhí)行
'使用前請(qǐng)修改SearchPath為實(shí)際路徑
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 & "個(gè)excel。"
End Sub
'按excel內(nèi)容整理文件夾內(nèi)容：將代碼復(fù)制到包含需要整理文件信息的excel執(zhí)行
'使用前請(qǐng)修改SearchPath為實(shí)際路徑
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 "結(jié)果文件夾" & RDir
End Sub
