Home |
Search |
Today's Posts |
#1
Posted to microsoft.public.excel.programming
|
|||
|
|||
Modifying Ron De Bruin's "Create summary sheet from different workbooks"
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 |
#2
Posted to microsoft.public.excel.programming
|
|||
|
|||
Modifying Ron De Bruin's "Create summary sheet from different workbooks"
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").SpecialCel ls(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 "Greg" wrote in message oups.com... 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 |
#3
Posted to microsoft.public.excel.programming
|
|||
|
|||
Modifying Ron De Bruin's "Create summary sheet from different workbooks"
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 "Ron de Bruin" wrote in message ... 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").SpecialCel ls(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 "Greg" wrote in message oups.com... 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 |
#4
Posted to microsoft.public.excel.programming
|
|||
|
|||
Modifying Ron De Bruin's "Create summary sheet from different workbooks"
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").SpecialCel ls(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 "Greg Souvan" wrote in message ... 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 "Ron de Bruin" wrote in message ... 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").SpecialCel ls(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 "Greg" wrote in message oups.com... 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 |
#5
Posted to microsoft.public.excel.programming
|
|||
|
|||
Modifying Ron De Bruin's "Create summary sheet from different workbooks"
On May 18, 12:16 am, "Ron de Bruin" wrote:
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").SpecialCel ls(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 "Greg Souvan" wrote in ... 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 "Ron de Bruin" wrote in message ... 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").SpecialCel ls(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 "Greg" wrote in message groups.com... 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 |
#6
Posted to microsoft.public.excel.programming
|
|||
|
|||
Modifying Ron De Bruin's "Create summary sheet from different workbooks"
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 "Greg" wrote in message ups.com... On May 18, 12:16 am, "Ron de Bruin" wrote: 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").SpecialCel ls(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 "Greg Souvan" wrote in ... 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 "Ron de Bruin" wrote in message ... 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").SpecialCel ls(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 "Greg" wrote in message groups.com... 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 |
#7
Posted to microsoft.public.excel.programming
|
|||
|
|||
Modifying Ron De Bruin's "Create summary sheet from different workbooks"
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 "Ron de Bruin" wrote in message ... 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 "Greg" wrote in message ups.com... On May 18, 12:16 am, "Ron de Bruin" wrote: 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").SpecialCel ls(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 "Greg Souvan" wrote in ... 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 "Ron de Bruin" wrote in message ... 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").SpecialCel ls(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 "Greg" wrote in message groups.com... 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 |
#8
Posted to microsoft.public.excel.programming
|
|||
|
|||
Modifying Ron De Bruin's "Create summary sheet from different workbooks"
Working OK for Greg now
-- Regards Ron de Bruin http://www.rondebruin.nl/tips.htm "Ron de Bruin" wrote in message ... 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 "Ron de Bruin" wrote in message ... 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 "Greg" wrote in message ups.com... On May 18, 12:16 am, "Ron de Bruin" wrote: 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").SpecialCel ls(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 "Greg Souvan" wrote in ... 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 "Ron de Bruin" wrote in message ... 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").SpecialCel ls(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 "Greg" wrote in message groups.com... 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 |
Reply |
Thread Tools | Search this Thread |
Display Modes | |
|
|
Similar Threads | ||||
Thread | Forum | |||
Excel "Worksheet Name" Building Function for Summary Sheet | Excel Discussion (Misc queries) | |||
Create a Summary of fields "NOT UPDATED"? | Excel Programming | |||
modifying the area plot to a "top-hat" instead of a "saw-tooth" | Charts and Charting in Excel | |||
How do I create an "outline summary" - please see message for deta | Excel Worksheet Functions | |||
use variable in Workbooks("book1").Worksheets("sheet1").Range("a1" | Excel Programming |