循环遍历某个范围内的每个工作簿

我有一个工作簿，其中一列包含 Excel 工作簿文件路径和文件名：

C:\D\Folder1\File1.xls
C:\D\Folder2\File2.xls
C:\D\Folder3\File3.xls

每个文件及其文件路径都是从上面的目录中提取的。

每个工作簿在单元格 C15 中都包含一个电子邮件地址，我想将其复制并粘贴到工作簿的相邻单元格中，如下所示：

C:D\\Folder1\File1.xls       [email protected]
C:\D\Folder2\File2.xls       [email protected]
C:\D\Folder3\File3.xls       [email protected]

我的代码仅检查一本工作簿并获取单元格 D17 中的一个电子邮件地址：

C:\D\Folder1\File1.xls       [email protected]
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()解决方案）。

我认为您是说您的工作表中已经有了路径和文件名列表，并且您只想使用这些文件中的某个单元格值填充工作表的每一行。有多种方法可以做到这一点，而无需每次实际打开工作簿（例如使用单元格公式，使用ADO, ExecuteExcel4Macro()）。其中任何一个都会对你很有帮助。

我个人偏好“生”ADO因为我可以更好地控制错误处理并检查表名称、工作表名称等。下面的代码显示了如何ExecuteExcel4Macro()可以工作（它的语法更简单，可能更适合您）。您必须将第一行代码中的工作表名称更改为工作表名称以及第二行文件名第一个单元格的范围地址。

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