遍历范围中的每个工作簿

Question

我的工作簿中包含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

Answer 1

正如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

Answer 2

以下代码应该有效。我不知道你想要用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

Answer 3

又一个解决方案：

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

Answer 4

您的问题有点不清楚（这就是为什么每个人都在提供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