|
|
楼主 |
发表于 2017-9-20 20:44
|
显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用 · 内置多项VBA编程加强工具 ★ 免费下载 ★ ★ 使用手册★
第十种方法：
Option Explicit
Dim fso As Object '模块级变量
Dim SourcePath As String, i%
Dim bReMoveVBC As Boolean
Dim ArrFiles(1 To 10000) '创建一个数组空间,用来存放文件名称
'主程序：通过递归，执行指定的操作
Sub main需确定是否删除宏()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
On Error Resume Next
Dim k%, wb As Workbook, j%
Dim arr(1 To 500, 1 To 70)
Set fso = CreateObject("scripting.filesystemobject")
'获取源路径
i = 0
SourcePath = getFolderPath("请选择源路径")
If SourcePath = "" Then End
' bReMoveVBC = MsgBox("是否清除文件中的宏代码？", vbYesNo) = vbYes
'递归
Call Recursion(SourcePath)
'显示结果
For k = 1 To i
Set wb = Workbooks.Open(ArrFiles(k))
With wb
With .Sheets(1)
j = j + 1
arr(j, 1) = .Range("D1")
arr(j, 2) = .Range("J1")
arr(j, 3) = .Range("O1")
arr(j, 4) = .Range("E7")
arr(j, 5) = .Range("E8")
arr(j, 6) = .Range("E9")
arr(j, 7) = .Range("E10")
arr(j, 8) = .Range("E11")
arr(j, 9) = .Range("E12")
arr(j, 10) = .Range("E13")
arr(j, 11) = .Range("M7")
arr(j, 12) = .Range("M8")
arr(j, 13) = .Range("M9")
arr(j, 14) = .Range("M10")
arr(j, 15) = .Range("M11")
arr(j, 16) = .Range("M12")
arr(j, 17) = .Range("B7")
arr(j, 18) = .Range("B8")
arr(j, 19) = .Range("B9")
arr(j, 20) = .Range("B10")
arr(j, 21) = .Range("B11")
arr(j, 22) = .Range("B12")
arr(j, 23) = .Range("B13")
arr(j, 24) = .Range("J7")
arr(j, 25) = .Range("J8")
arr(j, 26) = .Range("J9")
arr(j, 27) = .Range("J10")
arr(j, 28) = .Range("J11")
arr(j, 29) = .Range("J12")
arr(j, 30) = .Range("J15")
arr(j, 31) = .Range("J16")
arr(j, 32) = .Range("J17")
arr(j, 33) = .Range("J18")
arr(j, 34) = .Range("J19")
arr(j, 35) = .Range("J20")
arr(j, 36) = .Range("J21")
arr(j, 37) = .Range("J22")
arr(j, 38) = .Range("J23")
arr(j, 39) = .Range("J24")
arr(j, 40) = .Range("J25")
arr(j, 41) = .Range("J26")
arr(j, 42) = .Range("J27")
arr(j, 43) = .Range("J28")
arr(j, 44) = .Range("J29")
arr(j, 45) = .Range("J30")
arr(j, 46) = .Range("J31")
arr(j, 47) = .Range("J32")
arr(j, 48) = .Range("J33")
arr(j, 49) = .Range("J34")
arr(j, 50) = .Range("C15")
arr(j, 51) = .Range("C16")
arr(j, 52) = .Range("C17")
arr(j, 53) = .Range("C18")
arr(j, 54) = .Range("C19")
arr(j, 55) = .Range("C20")
arr(j, 56) = .Range("C21")
arr(j, 57) = .Range("C22")
arr(j, 58) = .Range("C23")
arr(j, 59) = .Range("C24")
arr(j, 60) = .Range("C25")
arr(j, 61) = .Range("C26")
arr(j, 62) = .Range("C27")
arr(j, 63) = .Range("C28")
arr(j, 64) = .Range("C29")
arr(j, 65) = .Range("C30")
arr(j, 66) = .Range("C31")
arr(j, 67) = .Range("C32")
arr(j, 68) = .Range("C33")
arr(j, 69) = .Range("C34")
End With
arr(j, 70) = .Name
.Close False
End With
Range("a" & 2).Resize(5000, 70).ClearContents
Range("a" & 2).Resize(5000, 70).Borders.LineStyle = xlNone
Range("a" & 2).Resize(j, 70) = arr
Range("a" & 2).Resize(j, 70).Borders.LineStyle = 1
Set wb = Nothing
Next
' Shell "explorer " & SourcePath & "\", vbNormalFocus
End Sub
'获取文件夹路径
Function getFolderPath(prompt) As String
Dim Objshell As Object, Objfolder As Object
Set Objshell = CreateObject("Shell.Application")
Set Objfolder = Objshell.BrowseForFolder(0, prompt, 0, 0)
If Objfolder Is Nothing Then getFolderPath = "" Else getFolderPath = Objfolder.self.Path
Set Objfolder = Nothing: Set Objshell = Nothing
End Function
'递归程序
Sub Recursion(myPath As String)
Dim myFolder As Object, mySubFolder As Object, myFile As Object
Dim wb As Workbook, j%
Set myFolder = fso.GetFolder(myPath)
'遍历文件夹
For Each mySubFolder In myFolder.SubFolders
Recursion mySubFolder.Path
Next
'遍历文件
For Each myFile In myFolder.Files
' Select Case fso.GetExtensionName(myPath & "\" & myFile)
' Case "xls", "xlsx" ', "xlsm"
If myFile Like "*.xls" Or myFile Like "*.xlsx" And myFile.Name <> ThisWorkbook.Name Then
i = i + 1
ArrFiles(i) = myFile
End If
' Case Else
' End Select
' Erase arr
Next
End Sub |
|
楼主: 乐乐2006201505
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2017-9-20 20:54
