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) whic
summaries and retreives data from over 70 spreadsheet if they have dat
in certain rows and columns. If the data has not been updated, it wil
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 t
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, chang
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 separate
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).Ro


'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


--
bsnapool
------------------------------------------------------------------------
bsnapool's Profile: http://www.excelforum.com/member.php...o&userid=36115
View this thread: http://www.excelforum.com/showthread...hreadid=567179