Excel 循环浏览范围内的每个工作簿

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

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

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

每个工作簿的单元格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

---

正如Vincent G所说，您的错误处理程序不好，如果在文件中循环，您也可以使用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

子目录loop（）
Dim FileName作为字符串，FilePath作为字符串，TargetValue作为字符串，HomeFile作为字符串
HomeFile=“TestBook.xlsx”
FilePath=“C:\”
FileName=dir（FilePath&“\”，vbNormal）
文件名“”时执行此操作
TargetValue=GetInfo（文件名、文件路径）
写入信息目标值，主文件
FileName=dir
环
端接头
函数GetInfo（ByRef TargetFile作为字符串，ByRef Folder作为字符串）作为字符串
工作簿。打开文件夹&“\”和目标文件
GetInfo=工作簿（TargetFile）.Worksheets（1）.Range（“D17”）.value
工作簿（目标文件）。关闭
端函数
Sub-WriteInfo（ByRef TargetVal作为字符串，HomeWorkbook作为字符串）
使用工作簿（家庭工作簿）。工作表（1）
.Range（“U”和.rows.count）.End（xlUp）.value=TargetVal
以
端接头

以下代码应该可以工作。我不知道您想要对Z列中的remove做什么，所以我只是用excel文件在所有行中复制了它

在这里，我假设活动工作表是工作表（1）

另一个解决方案：

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

选项显式
'根据需要修改
Const EXCELPATH=“C:\Temp\SO\”
Const EXCELFILES=“*.xls”
Const EMAILCELL=“D15”
Const SHEETNAME=“Sheet1”
子邮件（）
Dim XL作为对象的Excel.Application
将WB调整为对象的Excel.Workbook
将WS作为对象的Excel.Worksheet进行调整
将电池调暗为量程
将文件变暗为字符串
将异常文件设置为字符串
Set XL=CreateObject（“Excel.Application”）
theFile=Dir（EXCELPATH和EXCELFILES）
当文件“”时执行此操作
theExcelFile=EXCELPATH&theFile
设置WB=OpenWorkbook（XL，异常文件）
设置WS=WB.Sheets（图纸名称）
'*
“*在EMAILCELL中获取电子邮件地址
'*
设置cell=WS.Range（EMAILCELL）
Debug.Print“Email from”&theExcelFile&“：”&theCell.Value
'*
“*根据需要处理电子邮件地址
'*
'...... 你的代码。。。。。
'
theFile=Dir（）'下一个文件（如果有）
环
端接头
'******************************************
'*将WB作为工作簿对象返回
'*XL是Excel应用程序对象
'*
函数OpenWorkbook（XL作为对象，文件名作为字符串）作为对象
作为整数的Dim i
设置OpenWorkbook=XL.Workbooks.Open（文件名）
OpenWorkbook.Activate
'*
'*等待Excel文件打开。
'*
i=10
IsFileOpen（文件名）=False时执行
i=i-1
如果i=0，则退出Do
环
如果i=0，则MsgBox“打开Excel文件时出错：”&vbCrLf&Filename
端函数
'*********************************************************************************************************************
'*检查Office文件是否已打开
“*参考：http://accessexperts.com/blog/2012/03/06/checking-if-files-are-locked
’*简而言之：“小”应用程序（如记事本）不会锁定打开的文件，而办公应用程序会锁定打开的文件
'*下面的代码测试文件是否被锁定
'*
函数IsFileOpen（文件名为字符串）为布尔值
作为整数的Dim n
IsFileOpen=False
n=FreeFile（）'下一个自由文件
错误时转到打开
打开随机访问的文件名读写锁定读写为#n'错误（如果已锁定）
关不上
退出功能
开的：
IsFileOpen=True
错误转到0
端函数

您的问题有些不清楚（这就是为什么每个人都给您提供

Dir（）

解决方案的原因）

我认为您的意思是，您的工作表中已经有路径和文件名列表，您只是想用这些文件中的特定单元格值填充工作表的每一行。有很多方法可以做到这一点，而无需每次实际打开工作簿（例如使用单元格公式，使用

ADO

，

ExecuteExcel4Macro（）

）。这些东西中的任何一个都对你有好处

我个人喜欢使用“raw”

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

---

首先，Dir$是VBA中存在的一个函数，您不需要使用对wscript的过于复杂的调用。其次，您的错误处理不好。谢谢您的代码，但它似乎没有在文件目录中列出我的工作簿？我不确定你的代码和我的代码有什么不同：/@user7415328看看如何使用dir-它真的很有用。但简单地说，您看到了它在“do while”循环中的位置了吗？每次运行“filename=Dir$”时，字符串“filename”将更改为下一个文件名。整个目录是这样循环的（或者所有符合条件的文件）。@tompreston我不确定我是否理解。在我的文件被打印到coulm d之前，现在不是了？这段代码有什么不同之处导致它们不以相同的方式列出？@user7415328这段代码正在以D列打印文件名，但一次打印一个文件名，不像以前的代码那样一气呵成。@VincentG谢谢，我一直在等，代码是st

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