Loop through each workbook in a range

Question

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       [email protected]
C:\D\Folder2\File2.xls       [email protected]
C:\D\Folder3\File3.xls       [email protected]

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

C:\D\Folder1\File1.xls       [email protected]
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

Answer 1

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

Answer 2

As Vincent G said, your error handler is not good, and you may as well use Dir if looping through files (Its quick and easy to use). You might find it easier to split up the tasks. I've adapted some code I had in reserve, I think it will do what you need. If you don't understand it just ask.

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 3

The following code should work. I didn't know exactly what you wanted to do with the remove in column Z, so I just copied it in all rows with excel file.

Here I suppose the active sheet is worksheets(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 4

Yet another solution:

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