Hi All
Really stuck with this and would appreciate a helping hand.
The problem I have is... I have code (courtesy of al_b_c_nu) which summaries and retreives data from over 70 spreadsheet if they have data in certain rows and columns. If the data has not been updated, it will state "NOT UPDATED".
What I want to do is create a sheet which is like a chase up sheet, which looks up the data and if it says NOT UPDATED, to be copied to this "chase up sheet".
The code I have for this is below... Any ideas???
Thanks
Andrew
Really stuck with this and would appreciate a helping hand.
The problem I have is... I have code (courtesy of al_b_c_nu) which summaries and retreives data from over 70 spreadsheet if they have data in certain rows and columns. If the data has not been updated, it will state "NOT UPDATED".
What I want to do is create a sheet which is like a chase up sheet, which looks up the data and if it says NOT UPDATED, to be copied to this "chase up sheet".
The code I have for this is below... Any ideas???
Thanks
Andrew
Code:
Option Explicit
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
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 lRowStart As Long
Dim V As Variant, ChWeek As Variant, vFileList As Variant
Set wsSumm = Sheets("Summary")
'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("3:" & 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 + 2
wsSumm.Cells(lRowTo, "A").Value = Filenm
lRowStart = lRowTo + 1
'open File
Workbooks.Open FileName:=Folderpath & "\" & Filenm, ReadOnly:=True
ActiveWB = ActiveWorkbook.Name
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
Else
Application.StatusBar = "Processing " & Filenm & ": Week " & _
sWeeks(iWeekPtr)
'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
If LCase$(WS.Cells(R, "B").Text) <> "total" Then
For C = 6 To 12 'Cols F:L
If Application.IsNumber(WS.Cells(R, C)) Then 'Copy row to Summary
lRowTo = lRowTo + 1
With wsSumm
.Rows(lRowTo).Value = WS.Rows(R).Value
.Cells(lRowTo, "A").Value = "Week " & sWeeks(iWeekPtr)
End With
Exit For
End If
Next C
End If
Next R
End If
Else
lRowTo = lRowTo + 1
With wsSumm
.Cells(lRowTo, "A").Value = "Week " & sWeeks(iWeekPtr)
.Cells(lRowTo, "B").Value = "NOT FOUND"
End With
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
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
