Option Explicit
Dim wsLog As Worksheet
Sub ListInfobyFile()
Dim sWeeks() As String, sList As String
Dim iWeekPtr As Integer, iPtr As Integer
Dim iWkCur As Integer, iWkLow As Integer, iWkHigh As Integer
Dim wsSumm As Worksheet, WS As Worksheet, wsPWD As Worksheet
Dim Folderpath As String, Filenm As String
Dim I As Long, R As Long, C As Long, lRowTo As Long, lRowEnd As Long
Dim lRowStart As Long, lRowCU As Long, lErrNum As Long
Dim sPassword As String
Dim V As Variant, ChWeek As Variant, vFileList As Variant
Dim Bcol As Range
Dim firstAddress As String
Set wsSumm = ThisWorkbook.Sheets("Summary") ' Should be defined as ThisWorkbook
Set wsLog = ThisWorkbook.Worksheets("Activity Log") ' Should be defined as ThisWorkbook
Set wsPWD = ThisWorkbook.Sheets("Passwords") ' Should be defined as ThisWorkbook
'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)
vFileList = GetFileList(Folderpath & "/*.xls")
If IsArray(vFileList) = False Then
MsgBox "No Excel files found in " & Folderpath & vbCrLf & _
"Macro abandoned."
Exit Sub
End If
ChWeek = Application.InputBox(prompt:="Enter Week(s) required separated by comma" & vbCrLf & _
"(e.g. 1,2,3,4)..." & vbCrLf & _
"... or 'Cancel' to exit.", _
Type:=2)
If ChWeek = False Then Exit Sub
sWeeks = Split(ChWeek, ",")
iWkLow = 999
For iWeekPtr = LBound(sWeeks) To UBound(sWeeks)
iWkCur = Val(sWeeks(iWeekPtr))
If iWkCur < 1 Or iWkCur > 52 Then
MsgBox "Invalid Week number entered"
Exit Sub
End If
If iWkCur < iWkLow Then iWkLow = iWkCur
If iWkCur > iWkHigh Then iWkHigh = iWkCur
Next iWeekPtr
With wsSumm
lRowTo = .UsedRange.Row + .UsedRange.Rows.Count - 1
If lRowTo > 2 Then .Rows("5:" & lRowTo).ClearContents
lRowTo = .Cells(Rows.Count, "B").End(xlUp).Row + 1
End With
With Application
.ScreenUpdating = False
'Ensure macros dont fire when opening w/books
.EnableEvents = False
End With
For I = LBound(vFileList) To UBound(vFileList)
Filenm = vFileList(I)
If ThisWorkbook.Name <> Filenm Then
'Paste the name
lRowTo = lRowTo + 3
wsSumm.Cells(lRowTo, "A").Value = Filenm
lRowStart = lRowTo + 1
'open File
V = "*"
On Error Resume Next
V = WorksheetFunction.Match(Filenm, wsPWD.Columns("A"), 0)
On Error GoTo 0
If IsNumeric(V) Then
sPassword = wsPWD.Cells(V, "B").Text
Else
sPassword = ""
End If
On Error Resume Next
Workbooks.Open FileName:=Folderpath & "\" & Filenm, _
ReadOnly:=True, _
Password:=sPassword
lErrNum = Err.Number
On Error GoTo 0
If lErrNum > 0 Then
LogEntry ExcelFile:=Filenm, _
Week:="******", _
Message:="CANNOT OPEN"
Else
For iWeekPtr = LBound(sWeeks) To UBound(sWeeks)
Set WS = Nothing
On Error Resume Next
Set WS = Sheets(sWeeks(iWeekPtr))
On Error GoTo 0
If Not WS Is Nothing Then
If WS.Tab.ColorIndex = xlColorIndexNone Then
lRowTo = lRowTo + 1
With wsSumm
.Cells(lRowTo, "A").Value = "Week " & sWeeks(iWeekPtr)
.Cells(lRowTo, "B").Value = "NOT UPDATED"
End With
LogEntry ExcelFile:=Filenm, _
Week:="Week " & sWeeks(iWeekPtr), _
Message:="NOT UPDATED"
Else
Application.StatusBar = "Processing " & Filenm & ": Week " & _
sWeeks(iWeekPtr)
'Check Range
'Get last row to check
'lRowEnd = WS.Range("B" & Rows.Count).End(xlUp)' --->>> Removed not working due to
' This last row detect was not really being detected correctly as there was some other data down row 222 in col B workbook AEA
'------------------Find the which row total is in in the data source------
' Searches for Total…in Col B and set LrowEnd to one row less
'NOTE - becareful not put more than one "TOTAL" or "total" or "Total" _
or other combination in Col B of you sheets you get the data from.
With WS.Range("B12:B65336")
Set Bcol = .Find(LCase("TOTAL"), LookIn:=xlValues)
If Not Bcol Is Nothing Then
firstAddress = Bcol.Address
Do
lRowEnd = Bcol.Row - 1 ' set one row less than cell with "TOTAL"
Set Bcol = .FindNext(Bcol)
Loop While Not Bcol Is Nothing And Bcol.Address <> firstAddress
End If
End With
'===========Start of looking for the entries to copy ==========
For R = 12 To lRowEnd ' For Rows of 12 to last
If LCase$(WS.Cells(R, "B").Text) <> "Total" Then ' if the entry in Row B is not = Total
' For C = 6 To 7 'Cols F:L ' ===> Removed DOING NOTHING
If Application.CountA(WS.Range(WS.Cells(R, 6), WS.Cells(R, 12))) Or _
Application.CountA(WS.Range(WS.Cells(R, 14), WS.Cells(R, 15))) _
Then 'If there is entry in col F to L or N to S copy the row to Summary
lRowTo = lRowTo + 1 'last used row in the summary +1
With wsSumm ' the copy
.Rows(lRowTo).Value = WS.Rows(R).Value
.Cells(lRowTo, "A").Value = "Week " & sWeeks(iWeekPtr)
End With
Else 'Exit For '===> Removed DOING NOTHING
End If
Else
'Next C '===> Removed DOING NOTHING
End If
Next R
LogEntry ExcelFile:=Filenm, _
Week:="Week " & sWeeks(iWeekPtr), _
Message:="PROCESSED"
End If
Else
lRowTo = lRowTo + 1
With wsSumm
.Cells(lRowTo, "A").Value = "Week " & sWeeks(iWeekPtr)
.Cells(lRowTo, "B").Value = "NOT FOUND"
End With
LogEntry ExcelFile:=Filenm, _
Week:="Week " & sWeeks(iWeekPtr), _
Message:="NOT FOUND"
End If
Next iWeekPtr
lRowTo = lRowTo + 2
wsSumm.Cells(lRowTo, "B").Value = "TOTAL"
For iPtr = 1 To 7
wsSumm.Cells(lRowTo, iPtr + 5).FormulaR1C1 = "=sum(R" & lRowStart & "C:R[-1]C)"
Next iPtr
wsSumm.Cells(lRowTo, "M").FormulaR1C1 = "=sum(R" & lRowStart & "C:R[-1]C)"
With Application
.DisplayAlerts = False
ActiveWorkbook.Close
.DisplayAlerts = True
End With
End If
End If
Next I
lRowTo = lRowTo + 2
wsSumm.Cells(lRowTo, "B").Value = "GRAND TOTAL"
For iPtr = 1 To 7
wsSumm.Cells(lRowTo, iPtr + 5).FormulaR1C1 = "=sum(R4C:R[-1]C)/2"
Next iPtr
wsSumm.Cells(lRowTo, "M").FormulaR1C1 = "=sum(R4C:R[-1]C)/2"
With Application
.StatusBar = False
.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
Sub LogEntry(ByVal ExcelFile As String, _
ByVal Week As String, _
ByVal Message As String)
Dim lRow As Long
Dim vData(1 To 4) As Variant
lRow = wsLog.Cells(Rows.Count, "A").End(xlUp).Row + 1
vData(1) = Format(Now(), "dd-mmm-yy hh:mm:ss")
vData(2) = ExcelFile
vData(3) = Week
vData(4) = Message
wsLog.Range("A" & lRow & ":D" & lRow).Value = vData
End Sub
