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
Loop Through Multiple Workbooks and Worksheets Using An Array
Reply With Quote
