遍历一个范围内的每个工作簿
我有一个Excel工作簿文件path和文件名在一列的工作簿：
C:\D\Folder1\File1.xls C:\D\Folder2\File2.xls C:\D\Folder3\File3.xls 每个文件及其文件path都是从上面的目录中提取的。
这些工作簿中的每一个都包含单元格C15中的电子邮件地址，我想将其复制并粘贴到工作簿的相邻单元中，如下所示：
C:D\\Folder1\File1.xls email@email.com C:\D\Folder2\File2.xls email@email.com C:\D\Folder3\File3.xls email@email.com
我的代码只检查一个工作簿并抓取单元格D17中的一个电子邮件地址：
C:\D\Folder1\File1.xls email@email.com C:\D\Folder2\File2.xls C:\D\Folder3\File3.xls
如何循环访问列表中的每个工作簿。
这是我的代码：
Sub SO() Dim parentFolder As String parentFolder = Range("F11").Value & "\" '// change as required, keep trailing slash Dim results As String results = CreateObject("WScript.Shell").Exec("CMD /C DIR """ & parentFolder & "*.*"" /S /B /A:-D").StdOut.ReadAll Debug.Print results '// uncomment to dump results into column A of spreadsheet instead: Range("D17").Resize(UBound(Split(results, vbCrLf)), 1).Value = WorksheetFunction.Transpose(Split(results, vbCrLf)) Range("Z17").Resize(UBound(Split(results, vbCrLf)), 1).Value = "Remove" '//----------------------------------------------------------------- '// uncomment to filter certain files from results. '// Const filterType As String = "*.exe" '// Dim filterResults As String '// '// filterResults = Join(Filter(Split(results, vbCrLf), filterType), vbCrLf) '// '// Debug.Print filterResults On Error GoTo errHandler Application.DisplayAlerts = False Application.EnableEvents = False Application.ScreenUpdating = False Dim app As New Excel.Application app.Visible = False 'Visible is False by default, so this isn't necessary Dim x As Workbook Dim y As Workbook '## Open both workbooks first: Set x = Workbooks.Open(Range("D17").Value) Set y = ThisWorkbook 'Now, copy what you want from x: x.Worksheets(1).Range("C15").Copy 'Now, paste to y worksheet: y.Worksheets(1).Range("U17").PasteSpecial xlPasteValues 'Close x: x.Close Application.ScreenUpdating = True Application.DisplayAlerts = True Application.EnableEvents = True errHandler: Application.DisplayAlerts = False Application.EnableEvents = False Application.ScreenUpdating = False End Sub
你的问题有些不清楚（这就是为什么每个人都给你的Dir()解决scheme）。
我想你是说你已经在你的工作表中有path和文件名的列表，而你只是想用这些文件中的某个单元格值填充工作表的每一行。 有许多方法可以做到这一点，而不必每次都打开工作簿（例如使用单元格公式，使用ADO ， ExecuteExcel4Macro() ）。 其中任何一个都能为你服务。
我的个人偏好是“原始的” ADO因为我可以更好地控制error handling并检查表名，表名等。为你）。 您必须将第一行代码中的工作表名称更改为您的工作表名称以及第二行中文件名称的第一个单元格的范围地址。
Dim startCell As Range, fileRng As Range Dim files As Variant, values() As Variant Dim path As String, file As String, arg As String Dim r As Long, i As Long 'Acquire the names of your files With ThisWorkbook.Worksheets("Sheet1") 'amend to your sheet name Set startCell = .Range("F11") 'amend to start cell of file names Set fileRng = .Range(startCell, .Cells(.Rows.Count, startCell.Column).End(xlUp)) End With files = fileRng.Value2 'Size your output array ReDim values(1 To UBound(files, 1), 1 To 1) 'Populate output array with values from workbooks For r = 1 To UBound(files, 1) 'Create argument to read workbook value i = InStrRev(files(r, 1), "\") path = Left(files(r, 1), i) file = Right(files(r, 1), Len(files(r, 1)) - i) arg = "'" & path & "[" & file & "]Sheet1'!R15C3" 'Acquire the value values(r, 1) = ExecuteExcel4Macro(arg) Next 'Write values to sheet fileRng.Offset(, 1).Value = values
正如文森特G所说，你的error handling程序不好，你也可以使用Dir如果通过文件循环（它的快速和易于使用）。 您可能会发现分割任务更容易。 我已经调整了一些我准备好的代码，我想它会做你所需要的。 如果你不明白，就问问。
Sub DirectoryLoop() Dim FileName As String, FilePath As String, TargetValue As String, HomeFile As String HomeFile = "TestBook.xlsx" FilePath = "C:\" FileName = dir(FilePath & "\", vbNormal) Do While FileName <> "" TargetValue = GetInfo(FileName, FilePath) WriteInfo TargetValue, HomeFile FileName = dir Loop End Sub Function GetInfo(ByRef TargetFile As String, ByRef Folder As String) As String Workbooks.Open Folder & "\" & TargetFile GetInfo = Workbooks(TargetFile).Worksheets(1).Range("D17").value Workbooks(TargetFile).Close End Function Sub WriteInfo(ByRef TargetVal As String, HomeWorkbook As String) With Workbooks(HomeWorkbook).sheets(1) .Range("U" & .rows.count).End(xlUp).value = TargetVal End With End Sub
下面的代码应该工作。 我不知道你想要在Z列中删除的内容，所以我只是用excel文件将它复制到所有行中。
这里我假设活动工作表是工作表（1）。
Sub SO() Dim parentFolder As String Dim filename As String Dim wb As Workbook parentFolder = Range("F11").Value & "\" 'On Error GoTo errHandler Application.ScreenUpdating = False Application.DisplayAlerts = False Application.EnableEvents = False filename = Dir$(parentFolder & "*.*") Dim currentRow As Long currentRow = 17 Do While Len(filename) > 0 Cells(currentRow, 4).Value = filename ' 4 is U column 'this will fail if file is not excel file Set wb = Workbooks.Open(parentFolder & filename) Cells(currentRow, 21).Value = wb.Worksheets(1).Range("C15").Value ' 21 is U column wb.Close cells(currentRow,26).Value = "Remove" next_file: filename = Dir$ currentRow = currentRow + 1 Loop Application.ScreenUpdating = True Application.DisplayAlerts = True Application.EnableEvents = True Exit Sub errHandler: 'in case of error we skip and go to the next file. Resume next_file End Sub
又一个解决scheme：
Option Explicit 'Modify as needed Const EXCELPATH = "C:\Temp\SO\" Const EXCELFILES = "*.xls" Const EMAILCELL = "D15" Const SHEETNAME = "Sheet1" Sub GetEmails() Dim XL As Object 'Excel.Application Dim WB As Object 'Excel.Workbooks Dim WS As Object 'Excel.Worksheet Dim theCell As Range Dim theFile As String Dim theExcelFile As String Set XL = CreateObject("Excel.Application") theFile = Dir(EXCELPATH & EXCELFILES) Do While theFile <> "" theExcelFile = EXCELPATH & theFile Set WB = OpenWorkbook(XL, theExcelFile) Set WS = WB.Sheets(SHEETNAME) '* '* Get the email address in EMAILCELL '* Set theCell = WS.Range(EMAILCELL) Debug.Print "Email from " & theExcelFile & ": " & theCell.Value '* '* Handle the email address as desired '* '...... your code ..... ' theFile = Dir() 'Next file if any Loop End Sub '****************************************** '* Return WB as Workbook object '* XL is an Excel application object '* Function OpenWorkbook(XL As Object, Filename As String) As Object Dim i As Integer Set OpenWorkbook = XL.Workbooks.Open(Filename) OpenWorkbook.Activate '* '* Wait until the Excel file is open. '* i = 10 Do While IsFileOpen(Filename) = False i = i - 1 If i = 0 Then Exit Do Loop If i = 0 Then MsgBox "Error opening Excel file:" & vbCrLf & Filename End Function '********************************************************************************************************************* '* Check if an Office file is open '* Reference: http://accessexperts.com/blog/2012/03/06/checking-if-files-are-locked '* Short story: "small" applications like Notepad do not lock opened files whereas Office applications do '* The below code tests if a file is locked '* Function IsFileOpen(Filename As String) As Boolean Dim n As Integer IsFileOpen = False n = FreeFile() 'Next free On Error GoTo Opened Open Filename For Random Access Read Write Lock Read Write As #n 'Error if locked Close n 'Not locked Exit Function Opened: IsFileOpen = True On Error GoTo 0 End Function