Loop Through Multiple Workbooks and Worksheets Using An Array

I have the following code that will look for all the workbooks and search all the worksheets for a specific value and copy that value into the workbook that runs the macro. The code will open each workbook and cycle through each worksheet with the exception of the first worksheet and copy the value identified in the array and paste the results into the workbook running the macro. My question is, is there a way to copy the value from the workbooks without opening each workbook and cycle through each worksheet and paste? Looking for a way to simplify the code. As always, any help is greatly appreciated.

Code:

---

Public Sub Block()
    Dim wbk As Workbook
    Dim Filename As String
    Dim Path As String
    Dim FirstAddress As String
    Dim MyArr As Variant
    Dim Rng As Range
    Dim Rcount As Long
    Dim i As Long
    Dim NewSh As Worksheet
    Dim sh As Worksheet
    Dim LastRow1 As Long
    Dim x As Range
    Dim Tgt As Range
   
   
    Sheets("BlockList").Cells.Clear
'    With ActiveSheet
'    LastRow1 = .Cells(.Rows.Count, "A").End(xlUp).Row
'    End With
'
'    Set Tgt = ThisWorkbook.Sheets("DL").Cells(Rows.Count, 1).End(xlUp)(2)
   
    Path = "C:\LindaReports\"
    Filename = Dir(Path & "*.xls*")
    '--------------------------------------------
    'OPEN EXCEL FILES
    Do While Len(Filename) > 0 'IF NEXT FILE EXISTS THEN
   
    Set Tgt = ThisWorkbook.Sheets("BlockList").Cells(Rows.Count, 1).End(xlUp)(2)
   
      Set wbk = Workbooks.Open(Path & Filename)
       
        With Application
            .ScreenUpdating = False
            .EnableEvents = False
        End With
        'Fill in the search Value
        MyArr = Array("QC*")
        'Add new worksheet to your workbook to copy to
        'You can also use a existing sheet like this
        '    Set NewSh = Sheets("DL")
'        Set NewSh = Worksheets.Add
'        NewSh.Name = "DL"
        '    Cells(1, 1) = "EF"
        For Each sh In ActiveWorkbook.Worksheets
            Select Case "Summary"
            Case Else
               
               
                With sh.Cells.Range("A1:Z100")
                    '  LastRow1 = Sheets("DL").Cells(sh.Rows.Count, "A").End(xlUp).Row
                   
                    '    .Range ("A1:Z100")
                    'Range("A1", Columns("A").SpecialCells(xlCellTypeLastCell)).Delete
                   
                    '        Cells(LastRow1 + 1, 1).Activate
                    Rcount = 0 + Rcount
                    For i = LBound(MyArr) To UBound(MyArr)
                        Set Rng = .Find(What:=MyArr(i), _
                        after:=.Cells(.Cells.Count), _
                        LookIn:=xlFormulas, _
                        Lookat:=xlPart, _
                        SearchOrder:=xlByRows, _
                        SearchDirection:=xlNext, _
                        MatchCase:=False)
                        If Not Rng Is Nothing Then
                            FirstAddress = Rng.Address
                            Do
                                Rcount = Rcount + 1
                               
                                '                  Rng.Copy NewSh.Range("A" & Rcount)
                                '                    NewSh.Range("B" & Rcount).Resize(Rng.Rows.Count).Value = sh.Name
                                '                    NewSh.Range(LastRow1).Activate
                                ' Use this if you only want to copy the value
                                Tgt.Range("A" & Rcount).Value = wbk.Name
                                Tgt.Range("B" & Rcount).Resize(Rng.Rows.Count).Value = sh.Name
                                Tgt.Range("C" & Rcount).Value = Rng.Value
                               
                                '                      NewSh.Cells(LastRow1 + 1, Rcount) = Rng.Value
                               
                                Set Rng = .FindNext(Rng)
                            Loop While Not Rng Is Nothing And Rng.Address <> FirstAddress
                        End If
                    Next i
                End With
                With Application
                    .ScreenUpdating = True
                    .EnableEvents = True
                End With
            End Select
        Next sh
       
'      Range("A1").CurrentRegion.Copy Tgt
       
        '    MsgBox Filename & " has opened"
        wbk.Close True
        Filename = Dir
        Rcount = 0
       
    Loop
End Sub

---

Not that I know of.

you might be interested to look into PowerBI to aggregate the data - but even this will require it to lock and open the data file.

I've done what you have described - but you just gotta open dat file.
you can open silently and in read only mode.

I would also break your sub down into smaller chunks
> get/manage list of files to open, and call each in turn
> pass name to sub to open file, and return data array
> pass array to sub to write data to dest sheet

this will simplify your job a lot

There's a KB article that can read a single cell from a closed WB using the Excel 4 macro language

I did a quick test and it still works in Excel 2016

Multiple cells require multiple call, so it might be more effiecient to just open each WB if you have a lot of data to extract

Code:

---

Option Explicit
Sub drv()
    Dim OneCell As Variant
   
    OneCell = GetInfoFromClosedFile(Environ("USERPROFILE") & "\Documents", "ClosedFile.xlsx", "Sheet1", "A1")
    MsgBox OneCell

End Sub

'ref:  http://www.vbaexpress.com/kb/getarticle.php?kb_id=454

'extract data from a closed file by using an XLM macro. Credit for this technique goes to  John Walkenback  http://j-walk.com/ss/excel/tips/tip82.htm

Function GetInfoFromClosedFile(ByVal wbPath As String, wbName As String, wsName As String, cellRef As String) As Variant
   
    Dim sArg As String
   
    GetInfoFromClosedFile = vbNullString
   
    If Right(wbPath, 1) <> Application.PathSeparator Then wbPath = wbPath & Application.PathSeparator
   
    If Dir(wbPath & wbName) = "" Then Exit Function
       
    sArg = "'" & wbPath & "[" & wbName & "]" & wsName & "'!" & Range(cellRef).Address(True, True, xlR1C1)
   
    On Error Resume Next
    GetInfoFromClosedFile = ExecuteExcel4Macro(sArg)
    On Error GoTo 0
   
End Function

---

I think this is everything.

Code:

---

Sub FindRow14File()
    If ThisWorkbook.Worksheets("Admin").Range("B14").Value <> "" Then
        Call GetFilePath(14)
    Else
        MsgBox ("Please enter the staff member's name")
    End If
End Sub


Sub GetFilePath(myRow As Long)
'Return file name and path to worksheet cells


Dim myObject As Object
Dim fileSelected As String
Dim myPath As String
Dim myFile As String
Dim strLen As Integer


Set myObject = Application.FileDialog(msoFileDialogOpen)
myPath = ThisWorkbook.Worksheets("Admin").Range("E" & myRow).Value
myPath = GetDefaultLocation(myPath)
   
    With myObject
        .Title = "Choose File"
        .InitialFileName = myPath & "\"
        .AllowMultiSelect = False
        If .Show <> -1 Then
            MsgBox ("No File Selected")
            Exit Sub
        End If
        fileSelected = .SelectedItems(1)
    End With
   
    strLen = Len(fileSelected) - InStrRev(fileSelected, "\")
    myFile = Right(fileSelected, strLen)
    strLen = Len(fileSelected) - strLen - 1
    myPath = Left(fileSelected, strLen)
   
    With Worksheets("Admin")
        .Range("E" & myRow) = myPath 'The file path
        .Range("D" & myRow) = myFile 'The file name
        .Range("C" & myRow, "E" & myRow).Font.Color = vbBlack
    End With
End Sub


Function GetDefaultLocation(ByVal myString As String) As String
'check and return a valid default file location
Dim folderExists As Boolean


    On Error Resume Next
        folderExists = (GetAttr(myString) And vbDirectory) = vbDirectory
    On Error GoTo 0
   
    If folderExists Then
        GetDefaultLocation = myString
    Else
        GetDefaultLocation = Application.ThisWorkbook.Path
    End If


End Function

---

Code:

---

Sub CheckWBExists()
'cycle through listed input WBs and mark if any can't be found
Dim myArray() As String
Dim myString As String
Dim lastRow As Long, myRow As Long
Dim mySheet As Worksheet
Dim myFlag As Boolean


    Set mySheet = ThisWorkbook.Worksheets("Admin")
    ReDim myArray(1 To 1)
    lastRow = 4
    myFlag = False
   
    'get input dir/file strings
    Do While mySheet.Range("B" & lastRow + 1).Value <> ""
        myString = mySheet.Range("E" & lastRow).Value & "\" & mySheet.Range("D" & lastRow).Value
        myArray(UBound(myArray)) = myString
        lastRow = lastRow + 1
        ReDim Preserve myArray(1 To UBound(myArray) + 1)
    Loop
   
    myString = mySheet.Range("E" & lastRow).Value & "\" & mySheet.Range("D" & lastRow).Value
    myArray(UBound(myArray)) = myString


    'test input dir/file strings
    For myRow = 1 To UBound(myArray)
        myString = myArray(myRow)
        If Dir(myString) <> "" Then 'file exists at location
            mySheet.Rows(myRow + 3).EntireRow.Font.ColorIndex = 10
            mySheet.Range("C" & myRow + 3).ClearContents
        Else    'file does not exist at location
            mySheet.Rows(myRow + 3).EntireRow.Font.ColorIndex = 3
            mySheet.Range("C" & myRow + 3).Value = "File Not Found"
        End If
    Next myRow
   
    'warn and exit?
    If myFlag = True Then
        mySheet.Activate
        MsgBox ("Could not locate all input files. Please check and try again")
        GoTo FileNotFoundError
    End If
   
Exit Sub
FileNotFoundError:
    'stop code
    ResetApp
    End
   
End Sub

---

Code:

---

Public Sub RunFast()
' Settings to speed macro execution
' must use ResetApp sub to reverse (using an error handler if necessary)
Application.Calculation = xlCalculationManual
Application.DisplayStatusBar = True
Application.StatusBar = "Stand by: Running Macros."
Application.ScreenUpdating = False
End Sub


Public Sub ResetApp()
' settings to reset working environment at end of code execution
' may need to run this maually in event of incomplete execution of code sequence
    Application.Calculation = xlCalculationAutomatic
    Application.StatusBar = ""
    Application.ScreenUpdating = True
End Sub


Public Sub SilentOpen(myCmd As Boolean)
'supress "update links" and other on-open warings
'true = open silently
    Application.DisplayAlerts = Not (myCmd)
    Application.AskToUpdateLinks = Not (myCmd)
End Sub


Public Sub SilentClose(myWB As Workbook)
'close wb without saving or showing any prompts
    Application.DisplayAlerts = False
    myWB.Saved = True
    myWB.Close
    Application.DisplayAlerts = True
End Sub




Sub DelOldData()
' deletes any pre-existing data
Dim myRange As Range
Dim lastRow As Long
Dim mySheet As Worksheet


    Set mySheet = ThisWorkbook.Worksheets("Data")
    lastRow = mySheet.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Set myRange = mySheet.Range("A11:M" & lastRow)
    myRange.ClearContents


End Sub

---

Code:

---

Sub LoadNewData()
'Read new data into an array
'pass data to a "write sub"


Dim myArray() As String
Dim myRow As Long, lastRow As Long, myCount As Long
Dim destSheet As Worksheet, srcSheet As Worksheet
Dim myString As String
Dim myWB As Workbook, srcRange As Range


    Set destSheet = ThisWorkbook.Worksheets("Data")
   
    myArray = WBOpenStatus()    'returns array/list of WBs + open status
    If ProceedWithOpen(myArray()) = "False" Then GoTo UserCancels


    Call SilentOpen(True)
        For myCount = 2 To UBound(myArray, 2)  'loop through each workbook
            myString = myArray(2, myCount)
            Set myWB = GetNextWB(myString)      'open the file/open read only?
   
            'read the data
            Set srcSheet = myWB.Worksheets("Data Entry")
            lastRow = srcSheet.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            Set srcRange = srcSheet.Range("A11:K" & lastRow)
            Call WriteUpdateDate(myArray(1, myCount))
           
            'write the data
            lastRow = GetLastRow(destSheet)
            srcRange.Cells.Copy
                destSheet.Range("A" & lastRow).PasteSpecial Paste:=xlPasteValues
                Application.CutCopyMode = False
           
            'write the staff member name
            Do Until destSheet.Range("A" & lastRow) = ""
                destSheet.Range("L" & lastRow).Value = myArray(1, myCount)
                lastRow = lastRow + 1
            Loop
           
            'close the WB
            Call SilentClose(myWB)
        Next myCount
    Call SilentOpen(False)
   
    'remove any data validation
    destSheet.Cells.Validation.Delete
    Call GetClientOffice
    Call GetClientOrg
 
Exit Sub
UserCancels:
    ResetApp
    End 'quit if files are locked for editing and user cancels
   
End Sub


Sub WriteUpdateDate(myString As String)
'add date of last update to admin sheet list
Dim mySheet As Worksheet
Dim myRow As Long


Set mySheet = ThisWorkbook.Worksheets("Admin")


    For myRow = 4 To 14
        If mySheet.Range("B" & myRow).Value2 = myString Then
            mySheet.Range("C" & myRow) = Now()
            Exit For
        End If
    Next myRow


End Sub

Function GetNextWB(myString As String) As Workbook
'opens the source data WB & returns it as an object
    Set GetNextWB = Workbooks.Open( _
            FileName:=myString, _
            ReadOnly:=True, _
            UpdateLinks:=False)


End Function

Function ProceedWithOpen(myArray() As String) As String
'open each workbook and extract data or throw an error


Dim myFlag As Boolean
Dim myString As String
Dim myRow As Long


    myString = "Files belonging to: " & vbCrLf
   
    For myRow = 1 To UBound(myArray, 2)
        If myArray(3, myRow) = "True" Then
            myFlag = True
            myString = myString & "> " & myArray(1, myRow) & vbCrLf
        End If
    Next myRow
   
    If myFlag = True Then
        myString = myString & "are locked for editing. Proceed?"
        myFlag = Not (MsgBox(myString, vbYesNo))
    End If
   
    If myFlag = False Then
        ProceedWithOpen = "True"
    Else
        ProceedWithOpen = "False"
    End If
End Function


Function WBOpenStatus() As Variant
' check each listed WB to see if it is open
'return an array of file names and open status


Dim WBOpen As Boolean
Dim myRow As Long
Dim myArray() As String
Dim myName As String, myPath As String, myString As String, myStaff As String
Dim mySheet As Worksheet


Set mySheet = ThisWorkbook.Worksheets("Admin")
ReDim myArray(1 To 3, 1 To 1)
myRow = 4
   
    Do While mySheet.Range("B" & myRow).Value <> ""
        With mySheet
            myName = .Range("D" & myRow).Value
            myPath = .Range("E" & myRow).Value
            myStaff = .Range("B" & myRow).Value
        End With
        myString = myPath & "\" & myName
        ReDim Preserve myArray(1 To 3, 1 To UBound(myArray, 2) + 1)
       
        WBOpen = IsWorkBookOpen(myString)
       
        myArray(1, UBound(myArray, 2)) = myStaff
        myArray(2, UBound(myArray, 2)) = myString
        myArray(3, UBound(myArray, 2)) = WBOpen  'true means file is locked for editing
       
        myRow = myRow + 1
    Loop
   
    WBOpenStatus = myArray()
   
End Function


Function IsWorkBookOpen(FileName As String) As String
    Dim ff As Long, ErrNo As Long


    On Error Resume Next
    ff = FreeFile()
    Open FileName For Input Lock Read As #ff
    Close ff
    ErrNo = Err
    On Error GoTo 0


    Select Case ErrNo
    Case 0:    IsWorkBookOpen = "False"
    Case 70:  IsWorkBookOpen = "True"
    Case Else: Error ErrNo
    End Select
End Function

---

As you see, it takes a little bit to do the job well - but tis all doable.
I allow the user to specify the number and location of the input files, and set font formatting to show the validation status of the location info

@BenChod, Have you posted this issue on any other forum?