Hi

I have been using RDB's script for summarising a worksheet from
different workbooks to great effect. I have modified it to suit my
initial needs as below. However, I was wanting some (a lot) of
assistance to change/modify the "getopenfile" code to be able to read
a list of xls file names in a column and extract the same ranges into
the summary worksheet rather than opening a directory and selecting
files.

In essence, I want to have a worksheet with a list of xls file names
of workbooks that I will be able to extract data from each worksheet
that has the exact same structure. The data will be placed in rows
adjacent to the xls filename.

The whole project is about creating class/cohort summaries of student
grades from individual student profiles that have been created in
excel.

Regards

Greg

Sub Student_Summary_Year_11_C()
Dim FileNameXls As Variant
Dim SummWks As Worksheet
Dim ColNum As Integer
Dim myCell As Range, Rng As Range, fndFileName As Range
Dim RwNum As Long, FNum As Long, FinalSlash As Long
Dim ShName As String, PathStr As String
Dim SheetCheck As String, JustFileName As String
Dim JustFolder As String

ShName = "Maths C" 'Set sheet name to be summarised
Set Rng =
Range("K25,K23,k24,f26,j26,c26,k47,k45,k46,f48,j48 ,c48,k57,k55,k56,f58,j58,c58")
'Set cells to be referenced

'Select the files with GetOpenFilename
FileNameXls = Application.GetOpenFilename(filefilter:="Excel
Files,*.xls", _
MultiSelect:=True)

If IsArray(FileNameXls) = False Then
'do nothing
Else
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With

'Use this sheet for the Summary
Set SummWks = Sheets("summary") 'Set which sheet to
compile
report upon


For FNum = LBound(FileNameXls) To UBound(FileNameXls)

ColNum = 7 'Set grades in column
RwNum = LastRow(SummWks) + 1 'Set row number space
between
students
FinalSlash = InStrRev(FileNameXls(FNum), "\")
JustFileName = Mid(FileNameXls(FNum), FinalSlash + 1)
JustFolder = Left(FileNameXls(FNum), FinalSlash - 1)


'If the workbook name already exist in the sheet the row
color
will be Blue - NOT USED
'If the workbook name already exist in the sheet the font
color
will be Red
Set fndFileName = Nothing
Set fndFileName = SummWks.Cells.Find(JustFileName)
If Not fndFileName Is Nothing Then
SummWks.Cells(RwNum, 1).Resize(1, Rng.Cells.Count +
1).Font.Color = vbRed
Else
'Do nothing
End If


SummWks.Cells(RwNum, 2).Value = JustFileName 'copy the
workbook
name (student name) in correct column


'build the formula string
PathStr = "'" & JustFolder & "\[" & JustFileName & "]" &
ShName
& "'!"

On Error Resume Next
SheetCheck = ExecuteExcel4Macro(PathStr &
Range("A1").Address(,
, xlR1C1))
If Err.Number < 0 Then
'If the sheet name not exist in the workbook the row
color
will be Yellow.
SummWks.Cells(RwNum, 1).Resize(1, Rng.Cells.Count +
1).Interior.Color = vbYellow
Else
'Insert the formulas
For Each myCell In Rng.Cells
ColNum = ColNum + 1
SummWks.Cells(RwNum, ColNum).Formula = "=" &
PathStr &
myCell.Address
Next myCell
End If
On Error GoTo 0
Next FNum

' Use AutoFit for setting the column width in the new workbook
'SummWks.UsedRange.Columns.AutoFit - NOT USED
Columns("A:A").ColumnWidth = 3
Columns("B:B").ColumnWidth = 39
Columns("C:E").ColumnWidth = 3.86
Columns("F:G").ColumnWidth = 4.57
Columns("H:H").ColumnWidth = 5.29
Columns("I:K").ColumnWidth = 3.86
Columns("L:M").ColumnWidth = 4.57
Columns("N:N").ColumnWidth = 5.29
Columns("O:Q").ColumnWidth = 3.86
Columns("R:S").ColumnWidth = 4.57
Columns("T:U").ColumnWidth = 5.29
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
End If
End Sub


Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function