Hi All
The problem.
I have code which summaires 73 files within one folder. what I would like to do is add to this code to apply a date when the file was last updated?
Anyone know how to solve this problem?
E.g. The code retreives data from a selected week. It retreives all sickness data, from all 73 files. I would like to add to the code to say when the last time the workbook was updated?
Any help would be really really appreciated.
The code is below:
The problem.
I have code which summaires 73 files within one folder. what I would like to do is add to this code to apply a date when the file was last updated?
Anyone know how to solve this problem?
E.g. The code retreives data from a selected week. It retreives all sickness data, from all 73 files. I would like to add to the code to say when the last time the workbook was updated?
Any help would be really really appreciated.
The code is below:
Code:
Sub ListInfobyFile()
Dim wsSumm As Worksheet, WS As Worksheet
Dim Folderpath As String, Filenm As String, ActiveWB As String
Dim I As Long, R As Long, C As Long, lRowTo As Long, lRowEnd As Long
Dim V As Variant, ChWeek As Variant, vFileList As Variant
'Determine what tab to look in, A1 should have 1-52
'ChWeek = InputBox("What Week")
ChWeek = Application.InputBox(prompt:="What week?", Type:=2)
If IsNumeric(ChWeek) = False _
Or ChWeek < 1 _
Or ChWeek > 52 Then Exit Sub
Set wsSumm = Sheets("Summary")
lRowTo = wsSumm.Cells(Rows.Count, "A").End(xlUp).Row - 1
Range("A5").Select 'Start of the new list. Change as required
'Look in this file path to get a list of files in the folder, change this as required
Folderpath = ThisWorkbook.Path
Filenm = Dir(Folderpath & "\*.xls", vbNormal + vbReadOnly)
With Application
.ScreenUpdating = False
'Ensure macros dont fire when opening w/books
.EnableEvents = False
End With
vFileList = GetFileList(Folderpath & "/*.xls")
If IsArray(vFileList) Then
For I = LBound(vFileList) To UBound(vFileList)
Filenm = vFileList(I)
If ThisWorkbook.Name <> Filenm Then
'Paste the name
lRowTo = lRowTo + 2
wsSumm.Cells(lRowTo, "A").Value = Filenm
lRowTo = lRowTo + 1
'open File
Workbooks.Open FileName:=Folderpath & "\" & Filenm
ActiveWB = ActiveWorkbook.Name
Set WS = Nothing
On Error Resume Next
Set WS = Sheets(ChWeek)
On Error GoTo 0
If Not WS Is Nothing Then
'Check Range
'Get last row to check
lRowEnd = WS.Range("B" & Rows.Count).End(xlUp).Row
'Check for values in F:L
For R = 12 To lRowEnd
For C = 6 To 12 'Cols F:L
If Application.IsNumber(WS.Cells(R, C)) Then 'Copy row to Summary
lRowTo = lRowTo + 1
wsSumm.Rows(lRowTo).Value = WS.Rows(R).Value
Exit For
End If
Next C
Next R
End If
ActiveWorkbook.Close
End If
Next I
Else
MsgBox "No Excel files found in " & Folderpath
End If
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
Function GetFileList(FileSpec As String) As Variant
' Courtesy John Walkenbach
' Returns an array of filenames that match FileSpec
' If no matching files are found, it returns False
Dim FileArray() As Variant
Dim FileCount As Integer
Dim FileName As String
On Error GoTo NoFilesFound
FileCount = 0
FileName = Dir(FileSpec)
If FileName = "" Then GoTo NoFilesFound
' Loop until no more matching files are found
Do While FileName <> ""
FileCount = FileCount + 1
ReDim Preserve FileArray(1 To FileCount)
FileArray(FileCount) = FileName
FileName = Dir()
Loop
GetFileList = FileArray
Exit Function
' Error handler
NoFilesFound:
GetFileList = False
End Function
Andrew
