PDA

View Full Version : Loop Through Multiple Workbooks and Worksheets Using An Array



BenChod
06-01-2017, 11:32 AM
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.


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

werafa
06-02-2017, 02:30 AM
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

Paul_Hossler
06-02-2017, 04:49 AM
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




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

werafa
06-02-2017, 05:44 AM
I think this is everything.




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




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






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






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

werafa
06-02-2017, 05:47 AM
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

Aussiebear
06-02-2017, 08:10 PM
@BenChod, Have you posted this issue on any other forum?