遍历所有Excel并操作宏文档

'该Vba小程序用于 遍历当前Excel所在文件夹 及其 子文件夹 子子文件夹......下的所有Excel文档 返回文档路径至当前表A列 同时对遍历的所有表逐个进行行列操作（可录制）
'需运行Vba 工具——引用中的Microsoft Scripting Runtime
Dim ArrFiles(1 To 10000) '创建一个数组空间,用来存放文件名称
Dim cntFiles% '文件个数

Public Sub ListAllFiles()
Dim strPath$ '声明文件路径
Dim i as Long
Dim fso As New FileSystemObject, fd As Folder
strPath = ThisWorkbook.Path & "\"
cntFiles = 0
Set fd = fso.GetFolder(strPath)
SearchFiles fd
Sheets(1).Range("A1").Resize(cntFiles) = Application.Transpose(ArrFiles)
Sheets(1).Range("A1:A2").Delete Shift:=xlUp '删除前两行 宏excel目录



Sheets("Sheet1").Select
For i = 1 To 65536
Filename = Range("A" & i)
If Filename = "" Then
Exit Sub
Else
Workbooks.Open Filename:=Filename

Columns("A:A").Select '单表操作开始，录制开始
Selection.Delete Shift:=xlToLeft
Columns("C:C").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Columns("B:B").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlToLeft
Columns("C:G").Select
Selection.Delete Shift:=xlToLeft
Columns("D:D").Select
Columns("D:J").Select
Selection.Delete Shift:=xlToLeft
Columns("E:E").Select
Columns("E:O").Select
Selection.Delete Shift:=xlToLeft
ActiveWindow.ScrollColumn = 1
Columns("C:C").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range("C2").Select
ActiveCell.FormulaR1C1 = _
"=IF(RC[-2]="""","""",MID(RC[-2],8,2)&""-""&MID(RC[-2],14,6))"
Range("C2").Select
Selection.Copy
Application.Goto Reference:="R65536C3"
Range("C3:C65536").Select
Range("C65536").Activate
ActiveSheet.Paste
Columns("C:C").Select
Application.CutCopyMode = False
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ActiveWindow.SmallScroll Down:=6
Columns("A:A").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlToLeft
Columns("C:C").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range("C2").Select
ActiveCell.FormulaR1C1 = _
"=IF(RC[1]="""","""",IF(ISERROR(FIND(""["",RC[1])),RC[1],""[""&MID(RC[1],9,2)&""-""&RIGHT(RC[1],LEN(RC[1])-14)))"
Range("C2").Select
Selection.Copy
Application.Goto Reference:="R65536C3"
Range("C3:C65536").Select
Range("C65536").Activate
ActiveSheet.Paste
Columns("C:C").Select
Application.CutCopyMode = False
Selection.Copy
Selection.PasteSpecial Paste:=

xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Columns("D:D").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlToLeft
Rows("1:1").Select
Selection.Delete Shift:=xlUp
Application.Goto Reference:="R65536C6"
Columns("A:F").Select
Range("F65536").Activate
ActiveWorkbook.Worksheets(1).Sort.SortFields.Clear
ActiveWorkbook.Worksheets(1).Sort.SortFields.Add Key:=Columns( _
"B:B"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:= _
xlSortNormal
With ActiveWorkbook.Worksheets(1).Sort
.SetRange Columns("A:F")
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With '单表处理结束——录制结束处
Application.CutCopyMode = False
ActiveWorkbook.Save
ActiveWindow.Close
End If
Next i


End Sub

Sub SearchFiles(ByVal fd As Folder)
Dim fl As File
Dim sfd As Folder
For Each fl In fd.Files
cntFiles = cntFiles + 1
ArrFiles(cntFiles) = fl.Path

Next fl
If fd.SubFolders.Count = 0 Then Exit Sub
For Each sfd In fd.SubFolders
SearchFiles sfd
Next
End Sub