Home |
Search |
Today's Posts |
#1
![]()
Posted to microsoft.public.excel.programming
|
|||
|
|||
![]()
I've been trying to modify this Ron deBruin Macro that will create a summary
sheet from all of the selected files in a folder. However, I don't have a particular range that I need to sum. He has in his example a range of A1, D5:E5, Z10. However, I only need the last row in column H ("H" & LastRow). Cany anybody help me in modifying this? Thanks. Sub Summary_cells_from_Different_Workbooks_2() 'This example use the function LastRow 'This macro written by Ron deBruin, MVP 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 = "Sheet1" '<---- Change Set Rng = Range("A1,D5:E5,Z10") '<---- Change 'Select the files with GetOpenFilename FileNameXls = Application.GetOpenFilename(filefilter:="Excel Files, *.xl*", _ 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("Sheet2") '<---- Change For FNum = LBound(FileNameXls) To UBound(FileNameXls) ColNum = 1 RwNum = LastRow(SummWks) + 1 FinalSlash = InStrRev(FileNameXls(FNum), "\") JustFileName = Mid(FileNameXls(FNum), FinalSlash + 1) JustFolder = Left(FileNameXls(FNum), FinalSlash - 1) 'If the workbook name already exist the row color will be Blue 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) _ .Interior.Color = vbBlue Else 'Do nothing End If 'copy the workbook name in column A SummWks.Cells(RwNum, 1).Value = JustFileName 'build the formula string JustFileName = WorksheetFunction.Substitute(JustFileName, "'", "''") 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 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 to set the column width SummWks.UsedRange.Columns.AutoFit 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 -- Nothing in life is ever easy - just get used to that fact. |
Thread Tools | Search this Thread |
Display Modes | |
|
|
![]() |
||||
Thread | Forum | |||
XML-Gallery- Ron DeBruin | Excel Programming | |||
Modify Ron Debruin Macro - Prompting for range | Excel Programming | |||
Slow Macro - Delete Row Based on Condition-Modified Ron DeBruin Ma | Excel Programming | |||
Ron DeBruin Macro - Moving Sheet Name from Last Column to Column A | Excel Worksheet Functions | |||
modification of auto-multiple workbook macro, Ron DeBruin (Copy4) | Excel Programming |