在一个范围内循环每个工作簿 [英] Loop through each workbook in a range

问题描述

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

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

每个文件及其文件路径都从上述目录中被拉出。

这些工作簿包含单元格C15中的电子邮件地址，我想将其复制粘贴到我的工作簿的相邻单元格中：

  C：D\\\Folder1\File1.xls [e-mail] 
 C：\D\Folder2\File2.xls [e-mail] 
 C：\D\\ \\ Folder3\File3.xls [e-mail] 
  

我的代码只检查一个工作簿，并抓住一个单元格D17中的电子邮件地址：

  C：\D\Folder1\File1.xls [e-mail] 
 C：\D\Folder2\File2.xls 
 C：\D\Folder3\File3.xls 
  

如何循环浏览列表中的每个工作簿。

这是我的代码：

  Sub SO（）
 
 Dim parentFolder As String 
 
 parentFolder = Range（F11）。Value& \'//根据需要更改，保持尾随斜杠
 
 Dim results As String 
 
 results = CreateObject（WScript.Shell）。Exec（CMD / C DIR& parentFolder&*。*/ S / B /A:-D\").StdOut.ReadAll 
 
 Debug.Print结果
 
'//取消注释将结果转储到电子表格的A列：
 Range（D17）。调整大小（UBound（Split（results，vbCrLf））），1）.Value = WorksheetFunction.Transpose（Split ，vbCrLf））
 Range（Z17）。调整大小（UBound（Split（results，vbCrLf）），1）.Value =Remove
'// -------- -------------------------------------------------- ------- 
'//取消注释以从结果中过滤某些文件。 
'// Const filterType As String =* .exe
'// Dim filterResults As String 
'// 
'// filterResults = Join（Filter（Split结果，vbCrLf），filterType），vbCrLf）
'// 
'// Debug.Print filterResults 
错误GoTo errHandler 
 Application.DisplayAlerts = False 
应用程序.EnableEvents = False 
 Application.ScreenUpdating = False 
 
 
 Dim app As New Excel.Application 
 app.Visible = False默认情况下，Visible为False，所以这不需要
 
 Dim x As Workbook 
 Dim y As Workbook 
 
'##首先打开两个工作簿：
设置x = Workbooks.Open （范围（D17）。值）
设置y = ThisWorkbook 
 
'现在，从x复制你想要的东西：
 x.Worksheets（1）.Range C15）复制
 
'现在，粘贴到y工作表：
 y.Worksheets（1）.Range（U17）。PasteSpecial xlPasteValues 
 
'关闭x：
 x.Close 
 
 
 Application.ScreenUpdating = True 
 Application.DisplayAlerts = True 
应用程序lication.EnableEvents = True 
 
 errHandler：
 Application.DisplayAlerts = False 
 Application.EnableEvents = False 
 Application.ScreenUpdating = False 
 
 End Sub 
  

解决方案

你的问题有点不清楚每个人都在给你 Dir（）解决方案）。

我想你说你已经有您的工作表中的路径和文件名列表，您只需要从这些文件中填充工作表的每一行。有几种方法可以在不实际打开工作簿的情况下（例如使用单元格公式，使用 ADO ， ExecuteExcel4Macro（））。任何这些都可以为您服务。

我的个人偏好是raw ADO ，因为我可以保持更多控制错误处理和检查表名，工作表名称等。下面的代码显示了如何 ExecuteExcel4Macro（）可以工作（这有一个更简单的语法，可能更适合您）。您必须将第一行代码中的工作表名称更改为第二行的文件名称和文件名的第一个单元格的范围地址。

作为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

'获取文件的名称
将ThisWorkbook.Worksheets（Sheet1）修改为您的工作表名称
设置startCell = .Range（F11）'修改为启动文件名的单元格
设置fileRng = .Range（startCell，.Cells（.Rows.Count，startCell.Column）.End（xlUp））
结束
文件= fileRng.Value2

'大小您的输出数组
ReDim值（1到UBound（文件，1），1到1）

'使用工作簿中的值填充输出数组
对于r = 1到UBound（文件，1）
'创建参数以读取工作簿值
i = InStrRev（files（r，1 ），\）
path = Left （文件（r，1），i）
file = Right（files（r，1），Len（files（r，1）） - i）
arg ='&路径& [&档案& ] Sheet1'！R15C3
'获取值
值（r，1）= ExecuteExcel4Macro（arg）
下一个

'将值写入表
fileRng.Offset（，1）.Value = values

I have a workbook with Excel workbook file paths and file names in a column:

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

Each file and its file path is pulled from a directory like above.

Each of these workbooks contains an email address in cell C15 which I want to copy and paste into the adjacent cell of my workbook like so:

C:D\\Folder1\File1.xls       [e-mail]
C:\D\Folder2\File2.xls       [e-mail]
C:\D\Folder3\File3.xls       [e-mail]

My code only checks one workbook and grabs one email address in cell D17:

C:\D\Folder1\File1.xls       [e-mail]
C:\D\Folder2\File2.xls       
C:\D\Folder3\File3.xls   

How can I loop through each workbook in my list.

Here is my code:

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

解决方案

Your question is somewhat unclear (which is why everyone is giving your the Dir() solutions).

I think you're saying that you already have the list of path and file names in your worksheet and you simply want to populate each row of the worksheet with a certain cell value from those files. There are a number of ways you can do this without actually opening the workbooks each time (eg with a cell formula, using ADO, ExecuteExcel4Macro()). Any of these would serve you well.

My personal preference is for 'raw' ADO as I can keep more control for error handling and check for table names, sheet names, etc. The code below shows how ExecuteExcel4Macro() could work (which has a simpler syntax and might be more suitable for you). You'll have to change the name of the worksheet in the first line of code to your sheet name and the range address of the first cell of your file names on the second line.

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

这篇关于在一个范围内循环每个工作簿的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！