Modifying Ron De Bruin's "Create summary sheet from different workbooks"

[Greg]

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

 

[Ron de Bruin]

Hi Greg

I changed the first example on my page fast (not test it)
http://www.rondebruin.nl/summary2.htm

With in columns A in the sheet ron in my example the path/file names
Test this one(there is no error check in this example if the file exist)

We can add that but I must go now

Test it and post back

Sub Summary_cells_from_Different_Workbooks_1()
Dim cell As Range
Dim SummWks As Worksheet
Dim ColNum As Integer
Dim myCell As Range, Rng 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 = "Sheet1" '<---- Change
Set Rng = Range("A1,D5:E5,Z10") '<---- Change


With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With

'Add a new workbook with one sheet for the Summary
Set SummWks = Workbooks.Add(1).Worksheets(1)

'The links to the first workbook will start in row 2
RwNum = 1

For Each cell In ThisWorkbook.Sheets("ron").Columns("A").SpecialCells(xlCellTypeConstants)
ColNum = 1
RwNum = RwNum + 1
FinalSlash = InStrRev(cell.Value, "\")
JustFileName = Mid(cell.Value, FinalSlash + 1)
JustFolder = Left(cell.Value, FinalSlash - 1)

'copy the workbook name in column A
SummWks.Cells(RwNum, 1).Value = JustFileName

'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 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
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 cell

' Use AutoFit to set the column width in the new workbook
SummWks.UsedRange.Columns.AutoFit

MsgBox "The Summary is ready, save the file if you want to keep it"

With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With

End Sub


--

Regards Ron de Bruin
http://www.rondebruin.nl/tips.htm

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

 

[Greg Souvan]

Thanks Ron for your super fast response. The script works almost how I
would want it. How can I adjust it to read the files to summarise as eg:
student.xls rather than D:\summaries\student.xls?

The list of students is in a format without the pathways. Just as
student.xls

Otherwise, I know I can adjust the script to suit my needs. No error checks
are needed as this has been done in previous scripts to get to the point of
being able to summarise student results. Although, a student.xls file could
have been accidently deleted after results have been inputted! An error
check would be wise then.

Regards

Greg

Hi Greg

I changed the first example on my page fast (not test it)
http://www.rondebruin.nl/summary2.htm

With in columns A in the sheet ron in my example the path/file names
Test this one(there is no error check in this example if the file exist)

We can add that but I must go now

Test it and post back

Sub Summary_cells_from_Different_Workbooks_1()
Dim cell As Range
Dim SummWks As Worksheet
Dim ColNum As Integer
Dim myCell As Range, Rng 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 = "Sheet1" '<---- Change
Set Rng = Range("A1,D5:E5,Z10") '<---- Change


With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With

'Add a new workbook with one sheet for the Summary
Set SummWks = Workbooks.Add(1).Worksheets(1)

'The links to the first workbook will start in row 2
RwNum = 1

For Each cell In
ThisWorkbook.Sheets("ron").Columns("A").SpecialCells(xlCellTypeConstants)
ColNum = 1
RwNum = RwNum + 1
FinalSlash = InStrRev(cell.Value, "\")
JustFileName = Mid(cell.Value, FinalSlash + 1)
JustFolder = Left(cell.Value, FinalSlash - 1)

'copy the workbook name in column A
SummWks.Cells(RwNum, 1).Value = JustFileName

'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 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
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 cell

' Use AutoFit to set the column width in the new workbook
SummWks.UsedRange.Columns.AutoFit

MsgBox "The Summary is ready, save the file if you want to keep it"

With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With

End Sub


--

Regards Ron de Bruin
http://www.rondebruin.nl/tips.htm

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

 

[Ron de Bruin]

Hi Greg

Try this one

You can change this line
JustFolder = " D:\summaries"


Sub Summary_cells_from_Different_Workbooks_1()
Dim cell As Range
Dim SummWks As Worksheet
Dim ColNum As Integer
Dim myCell As Range, Rng As Range
Dim RwNum As Long, FNum As Long
Dim ShName As String, PathStr As String
Dim SheetCheck As String, JustFileName As String
Dim JustFolder As String

ShName = "Sheet1" '<---- Change
Set Rng = Range("A1,D5:E5,Z10") '<---- Change


With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With

'Add a new workbook with one sheet for the Summary
Set SummWks = Workbooks.Add(1).Worksheets(1)

'The links to the first workbook will start in row 2
RwNum = 1

'not add a slash here after the folder name
JustFolder = " D:\summaries"

For Each cell In ThisWorkbook.Sheets("ron").Columns("A").SpecialCells(xlCellTypeConstants)

ColNum = 1

JustFileName = cell.Value
RwNum = RwNum + 1

If Trim(cell.Value) <> "" Then

If Dir(JustFolder & "\" & JustFileName) <> "" Then

'copy the workbook name in column A
SummWks.Cells(RwNum, 1).Value = JustFileName

'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 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
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
Else
SummWks.Cells(RwNum, 1).Value = JustFileName & " ERROR"
End If
Else
SummWks.Cells(RwNum, 1).Value = "ERROR : Empty cell"
End If
Next cell

' Use AutoFit to set the column width in the new workbook
SummWks.UsedRange.Columns.AutoFit

MsgBox "The Summary is ready, save the file if you want to keep it"

With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With

End Sub


--

Regards Ron de Bruin
http://www.rondebruin.nl/tips.htm

Thanks Ron for your super fast response. The script works almost how I
would want it. How can I adjust it to read the files to summarise as eg:
student.xls rather than D:\summaries\student.xls?

The list of students is in a format without the pathways. Just as
student.xls

Otherwise, I know I can adjust the script to suit my needs. No error checks
are needed as this has been done in previous scripts to get to the point of
being able to summarise student results. Although, a student.xls file could
have been accidently deleted after results have been inputted! An error
check would be wise then.

Regards

Greg

Hi Greg

I changed the first example on my page fast (not test it)
http://www.rondebruin.nl/summary2.htm

With in columns A in the sheet ron in my example the path/file names
Test this one(there is no error check in this example if the file exist)

We can add that but I must go now

Test it and post back

Sub Summary_cells_from_Different_Workbooks_1()
Dim cell As Range
Dim SummWks As Worksheet
Dim ColNum As Integer
Dim myCell As Range, Rng 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 = "Sheet1" '<---- Change
Set Rng = Range("A1,D5:E5,Z10") '<---- Change


With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With

'Add a new workbook with one sheet for the Summary
Set SummWks = Workbooks.Add(1).Worksheets(1)

'The links to the first workbook will start in row 2
RwNum = 1

For Each cell In
ThisWorkbook.Sheets("ron").Columns("A").SpecialCells(xlCellTypeConstants)
ColNum = 1
RwNum = RwNum + 1
FinalSlash = InStrRev(cell.Value, "\")
JustFileName = Mid(cell.Value, FinalSlash + 1)
JustFolder = Left(cell.Value, FinalSlash - 1)

'copy the workbook name in column A
SummWks.Cells(RwNum, 1).Value = JustFileName

'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 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
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 cell

' Use AutoFit to set the column width in the new workbook
SummWks.UsedRange.Columns.AutoFit

MsgBox "The Summary is ready, save the file if you want to keep it"

With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With

End Sub


--

Regards Ron de Bruin
http://www.rondebruin.nl/tips.htm

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

 

[Greg]

Hi Greg

Try this one

You can change this line
JustFolder = " D:\summaries"

Sub Summary_cells_from_Different_Workbooks_1()
Dim cell As Range
Dim SummWks As Worksheet
Dim ColNum As Integer
Dim myCell As Range, Rng As Range
Dim RwNum As Long, FNum As Long
Dim ShName As String, PathStr As String
Dim SheetCheck As String, JustFileName As String
Dim JustFolder As String

ShName = "Sheet1" '<---- Change
Set Rng = Range("A1,D5:E5,Z10") '<---- Change

With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With

'Add a new workbook with one sheet for the Summary
Set SummWks = Workbooks.Add(1).Worksheets(1)

'The links to the first workbook will start in row 2
RwNum = 1

'not add a slash here after the folder name
JustFolder = " D:\summaries"

For Each cell In ThisWorkbook.Sheets("ron").Columns("A").SpecialCells(xlCellTypeConstants)

ColNum = 1

JustFileName = cell.Value
RwNum = RwNum + 1

If Trim(cell.Value) <> "" Then

If Dir(JustFolder & "\" & JustFileName) <> "" Then

'copy the workbook name in column A
SummWks.Cells(RwNum, 1).Value = JustFileName

'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 not exist in the workbook the row colorwill be Yellow.
SummWks.Cells(RwNum, 1).Resize(1, Rng.Cells.Count + 1) _
.Interior.Color = vbYellow
Else
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
Else
SummWks.Cells(RwNum, 1).Value = JustFileName & " ERROR"
End If
Else
SummWks.Cells(RwNum, 1).Value = "ERROR : Empty cell"
End If
Next cell

' Use AutoFit to set the column width in the new workbook
SummWks.UsedRange.Columns.AutoFit

MsgBox "The Summary is ready, save the file if you want to keep it"

With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With

End Sub

--

Regards Ron de Bruinhttp://www.rondebruin.nl/tips.htm

Thanks Ron for your super fast response. The script works almost how I
would want it. How can I adjust it to read the files to summarise as eg:
student.xls rather than D:\summaries\student.xls?

The list of students is in a format without the pathways. Just as
student.xls

Otherwise, I know I can adjust the script to suit my needs. No error checks
are needed as this has been done in previous scripts to get to the point of
being able to summarise student results. Although, a student.xls file could
have been accidently deleted after results have been inputted! An error
check would be wise then.

Regards

Greg

Hi Greg
I changed the first example on my page fast (not test it)
http://www.rondebruin.nl/summary2.htm
With in columns A in the sheet ron in my example the path/file names
Test this one(there is no error check in this example if the file exist)
We can add that but I must go now
Test it and post back
Sub Summary_cells_from_Different_Workbooks_1()
Dim cell As Range
Dim SummWks As Worksheet
Dim ColNum As Integer
Dim myCell As Range, Rng 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 = "Sheet1" '<---- Change
Set Rng = Range("A1,D5:E5,Z10") '<---- Change
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
'Add a new workbook with one sheet for the Summary
Set SummWks = Workbooks.Add(1).Worksheets(1)
'The links to the first workbook will start in row 2
RwNum = 1
For Each cell In
ThisWorkbook.Sheets("ron").Columns("A").SpecialCells(xlCellTypeConstants)
ColNum = 1
RwNum = RwNum + 1
FinalSlash = InStrRev(cell.Value, "\")
JustFileName = Mid(cell.Value, FinalSlash + 1)
JustFolder = Left(cell.Value, FinalSlash - 1)
'copy the workbook name in column A
SummWks.Cells(RwNum, 1).Value = JustFileName
'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 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
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 cell
' Use AutoFit to set the column width in the new workbook
SummWks.UsedRange.Columns.AutoFit
MsgBox "The Summary is ready, save the file if you want to keep it"
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
End Sub
--
Regards Ron de Bruin
http://www.rondebruin.nl/tips.htm
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,

...

read more »- Hide quoted text -

- Show quoted text -

Hi again

I have this script doing all that I need now except one thing. Some
of the student.xls files in the column list are
"O'Student.xls" (O'DONNELL.xls). In other words the use of an
apostrophe in the name. Trouble is, the script doesn't like it and
just places the file name in the row rather than the data it is
supposed to extract. Any thoughts except for physically renaming
these files and omitting the apostrophe in the file name.

Other wise, the script is working beautifully.

Greg

 

[Ron de Bruin]

I look at it tomorrow Greg after work

I have big problems with the Excel programming newsgroup in Windows Mail on this moment.
I not see the whole thread and must reset the group each time to see the complete thread

--

Regards Ron de Bruin
http://www.rondebruin.nl/tips.htm

Hi Greg

Try this one

You can change this line
JustFolder = " D:\summaries"

Sub Summary_cells_from_Different_Workbooks_1()
Dim cell As Range
Dim SummWks As Worksheet
Dim ColNum As Integer
Dim myCell As Range, Rng As Range
Dim RwNum As Long, FNum As Long
Dim ShName As String, PathStr As String
Dim SheetCheck As String, JustFileName As String
Dim JustFolder As String

ShName = "Sheet1" '<---- Change
Set Rng = Range("A1,D5:E5,Z10") '<---- Change

With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With

'Add a new workbook with one sheet for the Summary
Set SummWks = Workbooks.Add(1).Worksheets(1)

'The links to the first workbook will start in row 2
RwNum = 1

'not add a slash here after the folder name
JustFolder = " D:\summaries"

For Each cell In ThisWorkbook.Sheets("ron").Columns("A").SpecialCells(xlCellTypeConstants)

ColNum = 1

JustFileName = cell.Value
RwNum = RwNum + 1

If Trim(cell.Value) <> "" Then

If Dir(JustFolder & "\" & JustFileName) <> "" Then

'copy the workbook name in column A
SummWks.Cells(RwNum, 1).Value = JustFileName

'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 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
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
Else
SummWks.Cells(RwNum, 1).Value = JustFileName & " ERROR"
End If
Else
SummWks.Cells(RwNum, 1).Value = "ERROR : Empty cell"
End If
Next cell

' Use AutoFit to set the column width in the new workbook
SummWks.UsedRange.Columns.AutoFit

MsgBox "The Summary is ready, save the file if you want to keep it"

With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With

End Sub

--

Regards Ron de Bruinhttp://www.rondebruin.nl/tips.htm

Thanks Ron for your super fast response. The script works almost how I
would want it. How can I adjust it to read the files to summarise as eg:
student.xls rather than D:\summaries\student.xls?

The list of students is in a format without the pathways. Just as
student.xls

Otherwise, I know I can adjust the script to suit my needs. No error checks
are needed as this has been done in previous scripts to get to the point of
being able to summarise student results. Although, a student.xls file could
have been accidently deleted after results have been inputted! An error
check would be wise then.

Regards

Greg

Hi Greg
I changed the first example on my page fast (not test it)
http://www.rondebruin.nl/summary2.htm
With in columns A in the sheet ron in my example the path/file names
Test this one(there is no error check in this example if the file exist)
We can add that but I must go now
Test it and post back
Sub Summary_cells_from_Different_Workbooks_1()
Dim cell As Range
Dim SummWks As Worksheet
Dim ColNum As Integer
Dim myCell As Range, Rng 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 = "Sheet1" '<---- Change
Set Rng = Range("A1,D5:E5,Z10") '<---- Change
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
'Add a new workbook with one sheet for the Summary
Set SummWks = Workbooks.Add(1).Worksheets(1)
'The links to the first workbook will start in row 2
RwNum = 1
For Each cell In
ThisWorkbook.Sheets("ron").Columns("A").SpecialCells(xlCellTypeConstants)
ColNum = 1
RwNum = RwNum + 1
FinalSlash = InStrRev(cell.Value, "\")
JustFileName = Mid(cell.Value, FinalSlash + 1)
JustFolder = Left(cell.Value, FinalSlash - 1)
'copy the workbook name in column A
SummWks.Cells(RwNum, 1).Value = JustFileName
'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 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
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 cell
' Use AutoFit to set the column width in the new workbook
SummWks.UsedRange.Columns.AutoFit
MsgBox "The Summary is ready, save the file if you want to keep it"
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
End Sub
--
Regards Ron de Bruin
http://www.rondebruin.nl/tips.htm
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,

...

read more »- Hide quoted text -

- Show quoted text -

Hi again

I have this script doing all that I need now except one thing. Some
of the student.xls files in the column list are
"O'Student.xls" (O'DONNELL.xls). In other words the use of an
apostrophe in the name. Trouble is, the script doesn't like it and
just places the file name in the row rather than the data it is
supposed to extract. Any thoughts except for physically renaming
these files and omitting the apostrophe in the file name.

Other wise, the script is working beautifully.

Greg

 

[Ron de Bruin]

Ok, here is the fix

'build the formula string
JustFileName = WorksheetFunction.Substitute(JustFileName, "'", "''")
PathStr = "'" & JustFolder & "\[" & JustFileName & "]" & ShName & "'!"

We change the ' to '' if ithere is a ' in the file name

Let me know if it is working for you


--

Regards Ron de Bruin
http://www.rondebruin.nl/tips.htm

I look at it tomorrow Greg after work

I have big problems with the Excel programming newsgroup in Windows Mail on this moment.
I not see the whole thread and must reset the group each time to see the complete thread

--

Regards Ron de Bruin
http://www.rondebruin.nl/tips.htm

Hi Greg

Try this one

You can change this line
JustFolder = " D:\summaries"

Sub Summary_cells_from_Different_Workbooks_1()
Dim cell As Range
Dim SummWks As Worksheet
Dim ColNum As Integer
Dim myCell As Range, Rng As Range
Dim RwNum As Long, FNum As Long
Dim ShName As String, PathStr As String
Dim SheetCheck As String, JustFileName As String
Dim JustFolder As String

ShName = "Sheet1" '<---- Change
Set Rng = Range("A1,D5:E5,Z10") '<---- Change

With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With

'Add a new workbook with one sheet for the Summary
Set SummWks = Workbooks.Add(1).Worksheets(1)

'The links to the first workbook will start in row 2
RwNum = 1

'not add a slash here after the folder name
JustFolder = " D:\summaries"

For Each cell In ThisWorkbook.Sheets("ron").Columns("A").SpecialCells(xlCellTypeConstants)

ColNum = 1

JustFileName = cell.Value
RwNum = RwNum + 1

If Trim(cell.Value) <> "" Then

If Dir(JustFolder & "\" & JustFileName) <> "" Then

'copy the workbook name in column A
SummWks.Cells(RwNum, 1).Value = JustFileName

'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 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
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
Else
SummWks.Cells(RwNum, 1).Value = JustFileName & " ERROR"
End If
Else
SummWks.Cells(RwNum, 1).Value = "ERROR : Empty cell"
End If
Next cell

' Use AutoFit to set the column width in the new workbook
SummWks.UsedRange.Columns.AutoFit

MsgBox "The Summary is ready, save the file if you want to keep it"

With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With

End Sub

--

Regards Ron de Bruinhttp://www.rondebruin.nl/tips.htm

Thanks Ron for your super fast response. The script works almost how I
would want it. How can I adjust it to read the files to summarise as eg:
student.xls rather than D:\summaries\student.xls?

The list of students is in a format without the pathways. Just as
student.xls

Otherwise, I know I can adjust the script to suit my needs. No error checks
are needed as this has been done in previous scripts to get to the point of
being able to summarise student results. Although, a student.xls file could
have been accidently deleted after results have been inputted! An error
check would be wise then.


Hi Greg

I changed the first example on my page fast (not test it)
http://www.rondebruin.nl/summary2.htm

With in columns A in the sheet ron in my example the path/file names
Test this one(there is no error check in this example if the file exist)

We can add that but I must go now

Test it and post back

Sub Summary_cells_from_Different_Workbooks_1()
Dim cell As Range
Dim SummWks As Worksheet
Dim ColNum As Integer
Dim myCell As Range, Rng 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 = "Sheet1" '<---- Change
Set Rng = Range("A1,D5:E5,Z10") '<---- Change

With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With

'Add a new workbook with one sheet for the Summary
Set SummWks = Workbooks.Add(1).Worksheets(1)

'The links to the first workbook will start in row 2
RwNum = 1

For Each cell In
ThisWorkbook.Sheets("ron").Columns("A").SpecialCells(xlCellTypeConstants)
ColNum = 1
RwNum = RwNum + 1
FinalSlash = InStrRev(cell.Value, "\")
JustFileName = Mid(cell.Value, FinalSlash + 1)
JustFolder = Left(cell.Value, FinalSlash - 1)

'copy the workbook name in column A
SummWks.Cells(RwNum, 1).Value = JustFileName

'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 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
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 cell

' Use AutoFit to set the column width in the new workbook
SummWks.UsedRange.Columns.AutoFit

MsgBox "The Summary is ready, save the file if you want to keep it"

With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With

End Sub

Regards Ron de Bruin
http://www.rondebruin.nl/tips.htm

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.


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,

...

read more »- Hide quoted text -

- Show quoted text -

Hi again

I have this script doing all that I need now except one thing. Some
of the student.xls files in the column list are
"O'Student.xls" (O'DONNELL.xls). In other words the use of an
apostrophe in the name. Trouble is, the script doesn't like it and
just places the file name in the row rather than the data it is
supposed to extract. Any thoughts except for physically renaming
these files and omitting the apostrophe in the file name.

Other wise, the script is working beautifully.

Greg

 

[Ron de Bruin]

Working OK for Greg now

--

Regards Ron de Bruin
http://www.rondebruin.nl/tips.htm

Ok, here is the fix

'build the formula string
JustFileName = WorksheetFunction.Substitute(JustFileName, "'", "''")
PathStr = "'" & JustFolder & "\[" & JustFileName & "]" & ShName & "'!"

We change the ' to '' if ithere is a ' in the file name

Let me know if it is working for you


--

Regards Ron de Bruin
http://www.rondebruin.nl/tips.htm

I look at it tomorrow Greg after work

I have big problems with the Excel programming newsgroup in Windows Mail on this moment.
I not see the whole thread and must reset the group each time to see the complete thread

--

Regards Ron de Bruin
http://www.rondebruin.nl/tips.htm

Hi Greg

Try this one

You can change this line
JustFolder = " D:\summaries"

Sub Summary_cells_from_Different_Workbooks_1()
Dim cell As Range
Dim SummWks As Worksheet
Dim ColNum As Integer
Dim myCell As Range, Rng As Range
Dim RwNum As Long, FNum As Long
Dim ShName As String, PathStr As String
Dim SheetCheck As String, JustFileName As String
Dim JustFolder As String

ShName = "Sheet1" '<---- Change
Set Rng = Range("A1,D5:E5,Z10") '<---- Change

With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With

'Add a new workbook with one sheet for the Summary
Set SummWks = Workbooks.Add(1).Worksheets(1)

'The links to the first workbook will start in row 2
RwNum = 1

'not add a slash here after the folder name
JustFolder = " D:\summaries"

For Each cell In ThisWorkbook.Sheets("ron").Columns("A").SpecialCells(xlCellTypeConstants)

ColNum = 1

JustFileName = cell.Value
RwNum = RwNum + 1

If Trim(cell.Value) <> "" Then

If Dir(JustFolder & "\" & JustFileName) <> "" Then

'copy the workbook name in column A
SummWks.Cells(RwNum, 1).Value = JustFileName

'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 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
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
Else
SummWks.Cells(RwNum, 1).Value = JustFileName & " ERROR"
End If
Else
SummWks.Cells(RwNum, 1).Value = "ERROR : Empty cell"
End If
Next cell

' Use AutoFit to set the column width in the new workbook
SummWks.UsedRange.Columns.AutoFit

MsgBox "The Summary is ready, save the file if you want to keep it"

With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With

End Sub

--

Regards Ron de Bruinhttp://www.rondebruin.nl/tips.htm



Thanks Ron for your super fast response. The script works almost how I
would want it. How can I adjust it to read the files to summarise as eg:
student.xls rather than D:\summaries\student.xls?

The list of students is in a format without the pathways. Just as
student.xls

Otherwise, I know I can adjust the script to suit my needs. No error checks
are needed as this has been done in previous scripts to get to the point of
being able to summarise student results. Although, a student.xls file could
have been accidently deleted after results have been inputted! An error
check would be wise then.

Regards

Greg

Hi Greg

I changed the first example on my page fast (not test it)
http://www.rondebruin.nl/summary2.htm

With in columns A in the sheet ron in my example the path/file names
Test this one(there is no error check in this example if the file exist)

We can add that but I must go now

Test it and post back

Sub Summary_cells_from_Different_Workbooks_1()
Dim cell As Range
Dim SummWks As Worksheet
Dim ColNum As Integer
Dim myCell As Range, Rng 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 = "Sheet1" '<---- Change
Set Rng = Range("A1,D5:E5,Z10") '<---- Change

With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With

'Add a new workbook with one sheet for the Summary
Set SummWks = Workbooks.Add(1).Worksheets(1)

'The links to the first workbook will start in row 2
RwNum = 1

For Each cell In
ThisWorkbook.Sheets("ron").Columns("A").SpecialCells(xlCellTypeConstants)
ColNum = 1
RwNum = RwNum + 1
FinalSlash = InStrRev(cell.Value, "\")
JustFileName = Mid(cell.Value, FinalSlash + 1)
JustFolder = Left(cell.Value, FinalSlash - 1)

'copy the workbook name in column A
SummWks.Cells(RwNum, 1).Value = JustFileName

'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 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
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 cell

' Use AutoFit to set the column width in the new workbook
SummWks.UsedRange.Columns.AutoFit

MsgBox "The Summary is ready, save the file if you want to keep it"

With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With

End Sub

--

Regards Ron de Bruin
http://www.rondebruin.nl/tips.htm

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,

...

read more »- Hide quoted text -

- Show quoted text -

Hi again

I have this script doing all that I need now except one thing. Some
of the student.xls files in the column list are
"O'Student.xls" (O'DONNELL.xls). In other words the use of an
apostrophe in the name. Trouble is, the script doesn't like it and
just places the file name in the row rather than the data it is
supposed to extract. Any thoughts except for physically renaming
these files and omitting the apostrophe in the file name.

Other wise, the script is working beautifully.

Greg