How to change this Ron deBruin Macro

K

KennyD

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
 
P

Paul

Have you tried :
Set Rng = Range("H"&LastRow)

--
If the post is helpful, please consider donating something to an animal
charity on my behalf.


KennyD said:
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
Click to expand...
 
M

marcus

Hi Kenny

I would have thought Set Rng = Range("H"&LastRow) will give you the
sum of the last unused row in Col H which will be zero as it won't
have anything in it.

Something like Set Rng = Range("H2:H"&LastRow)

will give you the range from H2 to the last row in that range.
Alternatively incorporate the followning which I had the chance to
test.

Take Care

Marcus


Sub testo()
Dim lw As Integer
lw = Range("H" & Rows.Count).End(xlUp).Row + 1
myRange = ActiveSheet.Range("H2", Range("H2").End(xlDown))
Range("H" & lw) = WorksheetFunction.Sum(myRange)
End Sub
 
R

Ron de Bruin

If you want to find the last cell in H you must open each file.
The code example you use now will create links and not open the file


Try this for the first sheet in each workbook
Change the path to your folder here

MyPath = "C:\Users\Ron Desktop\test"


Sub Basic_Example_1()
Dim MyPath As String, FilesInPath As String
Dim MyFiles() As String
Dim SourceRcount As Long, Fnum As Long
Dim mybook As Workbook, BaseWks As Worksheet
Dim sourceRange As Range, destrange As Range
Dim rnum As Long, CalcMode As Long

'Fill in the path\folder where the files are
MyPath = "C:\Users\Ron Desktop\test"

'Add a slash at the end if the user forget it
If Right(MyPath, 1) <> "\" Then
MyPath = MyPath & "\"
End If

'If there are no Excel files in the folder exit the sub
FilesInPath = Dir(MyPath & "*.xl*")
If FilesInPath = "" Then
MsgBox "No files found"
Exit Sub
End If

'Fill the array(myFiles)with the list of Excel files in the folder
Fnum = 0
Do While FilesInPath <> ""
Fnum = Fnum + 1
ReDim Preserve MyFiles(1 To Fnum)
MyFiles(Fnum) = FilesInPath
FilesInPath = Dir()
Loop

'Change ScreenUpdating, Calculation and EnableEvents
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With

'Add a new workbook with one sheet
Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
rnum = 1

'Loop through all files in the array(myFiles)
If Fnum > 0 Then
For Fnum = LBound(MyFiles) To UBound(MyFiles)
Set mybook = Nothing
On Error Resume Next
Set mybook = Workbooks.Open(MyPath & MyFiles(Fnum))
On Error GoTo 0

If Not mybook Is Nothing Then

On Error Resume Next

With mybook.Worksheets(1)
Set sourceRange = .Range("H" & LastRow(mybook.Worksheets(1)))
End With

If Err.Number > 0 Then
Err.Clear
Set sourceRange = Nothing
Else
'if SourceRange use all columns then skip this file
If sourceRange.Columns.Count >= BaseWks.Columns.Count Then
Set sourceRange = Nothing
End If
End If
On Error GoTo 0

If Not sourceRange Is Nothing Then

SourceRcount = sourceRange.Rows.Count

If rnum + SourceRcount >= BaseWks.Rows.Count Then
MsgBox "Sorry there are not enough rows in the sheet"
BaseWks.Columns.AutoFit
mybook.Close savechanges:=False
GoTo ExitTheSub
Else

'Copy the file name in column A
With sourceRange
BaseWks.Cells(rnum, "A"). _
Resize(.Rows.Count).Value = MyFiles(Fnum)
End With

'Set the destrange
Set destrange = BaseWks.Range("B" & rnum)

'we copy the values from the sourceRange to the destrange
With sourceRange
Set destrange = destrange. _
Resize(.Rows.Count, .Columns.Count)
End With
destrange.Value = sourceRange.Value

rnum = rnum + SourceRcount
End If
End If
mybook.Close savechanges:=False
End If

Next Fnum
BaseWks.Columns.AutoFit
End If

ExitTheSub:
'Restore ScreenUpdating, Calculation and EnableEvents
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalcMode
End With
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

Se also
http://www.rondebruin.nl/copy3.htm





--

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


KennyD said:
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
Click to expand...
 
D

Don Guillett

Try this idea to find the last row in CLOSED workbooks and then use it

Sub GetLastValueInColH_ClosedWBSAS()
'Gets row number in col 8'H
'uses to get value from that cell

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim FN As String
Dim myrow As Long
FN = Dir("C:\a\*.xls")
myrow = 1
Do Until FN = ""
'looking for files named file1.xls., file2.xls, etc
If LCase(Left(FN, 4)) = "file" Then
'MsgBox FN
Cells(myrow, 1).Formula = _
"=MATCH(999999999,'C:\a\[" & FN & "]Sheet1'!$H:$H)"
Cells(myrow, 2).Formula = _
"=[" & FN & "]sheet1!R" & Cells(myrow, 1) & "C8"
myrow = myrow + 1
End If
FN = Dir
Loop
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub

--
Don Guillett
Microsoft MVP Excel
SalesAid Software
(e-mail address removed)
KennyD said:
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
Click to expand...
 
K

KennyD

Ron,

Um ... what can I say??? That worked absolutely perfect. Thank you so
much. Your talent and willingness to share your knowledge is a tribute to
this community. Thanks again.

Best Regards,
Ken
--
Nothing in life is ever easy - just get used to that fact.


Ron de Bruin said:
If you want to find the last cell in H you must open each file.
The code example you use now will create links and not open the file


Try this for the first sheet in each workbook
Change the path to your folder here

MyPath = "C:\Users\Ron Desktop\test"


Sub Basic_Example_1()
Dim MyPath As String, FilesInPath As String
Dim MyFiles() As String
Dim SourceRcount As Long, Fnum As Long
Dim mybook As Workbook, BaseWks As Worksheet
Dim sourceRange As Range, destrange As Range
Dim rnum As Long, CalcMode As Long

'Fill in the path\folder where the files are
MyPath = "C:\Users\Ron Desktop\test"

'Add a slash at the end if the user forget it
If Right(MyPath, 1) <> "\" Then
MyPath = MyPath & "\"
End If

'If there are no Excel files in the folder exit the sub
FilesInPath = Dir(MyPath & "*.xl*")
If FilesInPath = "" Then
MsgBox "No files found"
Exit Sub
End If

'Fill the array(myFiles)with the list of Excel files in the folder
Fnum = 0
Do While FilesInPath <> ""
Fnum = Fnum + 1
ReDim Preserve MyFiles(1 To Fnum)
MyFiles(Fnum) = FilesInPath
FilesInPath = Dir()
Loop

'Change ScreenUpdating, Calculation and EnableEvents
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With

'Add a new workbook with one sheet
Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
rnum = 1

'Loop through all files in the array(myFiles)
If Fnum > 0 Then
For Fnum = LBound(MyFiles) To UBound(MyFiles)
Set mybook = Nothing
On Error Resume Next
Set mybook = Workbooks.Open(MyPath & MyFiles(Fnum))
On Error GoTo 0

If Not mybook Is Nothing Then

On Error Resume Next

With mybook.Worksheets(1)
Set sourceRange = .Range("H" & LastRow(mybook.Worksheets(1)))
End With

If Err.Number > 0 Then
Err.Clear
Set sourceRange = Nothing
Else
'if SourceRange use all columns then skip this file
If sourceRange.Columns.Count >= BaseWks.Columns.Count Then
Set sourceRange = Nothing
End If
End If
On Error GoTo 0

If Not sourceRange Is Nothing Then

SourceRcount = sourceRange.Rows.Count

If rnum + SourceRcount >= BaseWks.Rows.Count Then
MsgBox "Sorry there are not enough rows in the sheet"
BaseWks.Columns.AutoFit
mybook.Close savechanges:=False
GoTo ExitTheSub
Else

'Copy the file name in column A
With sourceRange
BaseWks.Cells(rnum, "A"). _
Resize(.Rows.Count).Value = MyFiles(Fnum)
End With

'Set the destrange
Set destrange = BaseWks.Range("B" & rnum)

'we copy the values from the sourceRange to the destrange
With sourceRange
Set destrange = destrange. _
Resize(.Rows.Count, .Columns.Count)
End With
destrange.Value = sourceRange.Value

rnum = rnum + SourceRcount
End If
End If
mybook.Close savechanges:=False
End If

Next Fnum
BaseWks.Columns.AutoFit
End If

ExitTheSub:
'Restore ScreenUpdating, Calculation and EnableEvents
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalcMode
End With
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

Se also
http://www.rondebruin.nl/copy3.htm





--

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


KennyD said:
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
Click to expand...
.
Click to expand...
 
R

Ron de Bruin

You are welcome


--

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


KennyD said:
Ron,

Um ... what can I say??? That worked absolutely perfect. Thank you so
much. Your talent and willingness to share your knowledge is a tribute to
this community. Thanks again.

Best Regards,
Ken
--
Nothing in life is ever easy - just get used to that fact.


Ron de Bruin said:
If you want to find the last cell in H you must open each file.
The code example you use now will create links and not open the file


Try this for the first sheet in each workbook
Change the path to your folder here

MyPath = "C:\Users\Ron Desktop\test"


Sub Basic_Example_1()
Dim MyPath As String, FilesInPath As String
Dim MyFiles() As String
Dim SourceRcount As Long, Fnum As Long
Dim mybook As Workbook, BaseWks As Worksheet
Dim sourceRange As Range, destrange As Range
Dim rnum As Long, CalcMode As Long

'Fill in the path\folder where the files are
MyPath = "C:\Users\Ron Desktop\test"

'Add a slash at the end if the user forget it
If Right(MyPath, 1) <> "\" Then
MyPath = MyPath & "\"
End If

'If there are no Excel files in the folder exit the sub
FilesInPath = Dir(MyPath & "*.xl*")
If FilesInPath = "" Then
MsgBox "No files found"
Exit Sub
End If

'Fill the array(myFiles)with the list of Excel files in the folder
Fnum = 0
Do While FilesInPath <> ""
Fnum = Fnum + 1
ReDim Preserve MyFiles(1 To Fnum)
MyFiles(Fnum) = FilesInPath
FilesInPath = Dir()
Loop

'Change ScreenUpdating, Calculation and EnableEvents
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With

'Add a new workbook with one sheet
Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
rnum = 1

'Loop through all files in the array(myFiles)
If Fnum > 0 Then
For Fnum = LBound(MyFiles) To UBound(MyFiles)
Set mybook = Nothing
On Error Resume Next
Set mybook = Workbooks.Open(MyPath & MyFiles(Fnum))
On Error GoTo 0

If Not mybook Is Nothing Then

On Error Resume Next

With mybook.Worksheets(1)
Set sourceRange = .Range("H" & LastRow(mybook.Worksheets(1)))
End With

If Err.Number > 0 Then
Err.Clear
Set sourceRange = Nothing
Else
'if SourceRange use all columns then skip this file
If sourceRange.Columns.Count >= BaseWks.Columns.Count Then
Set sourceRange = Nothing
End If
End If
On Error GoTo 0

If Not sourceRange Is Nothing Then

SourceRcount = sourceRange.Rows.Count

If rnum + SourceRcount >= BaseWks.Rows.Count Then
MsgBox "Sorry there are not enough rows in the sheet"
BaseWks.Columns.AutoFit
mybook.Close savechanges:=False
GoTo ExitTheSub
Else

'Copy the file name in column A
With sourceRange
BaseWks.Cells(rnum, "A"). _
Resize(.Rows.Count).Value = MyFiles(Fnum)
End With

'Set the destrange
Set destrange = BaseWks.Range("B" & rnum)

'we copy the values from the sourceRange to the destrange
With sourceRange
Set destrange = destrange. _
Resize(.Rows.Count, .Columns.Count)
End With
destrange.Value = sourceRange.Value

rnum = rnum + SourceRcount
End If
End If
mybook.Close savechanges:=False
End If

Next Fnum
BaseWks.Columns.AutoFit
End If

ExitTheSub:
'Restore ScreenUpdating, Calculation and EnableEvents
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalcMode
End With
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

Se also
http://www.rondebruin.nl/copy3.htm





--

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


KennyD said:
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
Click to expand...
.
Click to expand...
Click to expand...
 
K

KennyD

Ron,

Where at in this macro would I enter any formatting that I might want to do
to the new worksheet?

--
Nothing in life is ever easy - just get used to that fact.


Ron de Bruin said:
If you want to find the last cell in H you must open each file.
The code example you use now will create links and not open the file


Try this for the first sheet in each workbook
Change the path to your folder here

MyPath = "C:\Users\Ron Desktop\test"


Sub Basic_Example_1()
Dim MyPath As String, FilesInPath As String
Dim MyFiles() As String
Dim SourceRcount As Long, Fnum As Long
Dim mybook As Workbook, BaseWks As Worksheet
Dim sourceRange As Range, destrange As Range
Dim rnum As Long, CalcMode As Long

'Fill in the path\folder where the files are
MyPath = "C:\Users\Ron Desktop\test"

'Add a slash at the end if the user forget it
If Right(MyPath, 1) <> "\" Then
MyPath = MyPath & "\"
End If

'If there are no Excel files in the folder exit the sub
FilesInPath = Dir(MyPath & "*.xl*")
If FilesInPath = "" Then
MsgBox "No files found"
Exit Sub
End If

'Fill the array(myFiles)with the list of Excel files in the folder
Fnum = 0
Do While FilesInPath <> ""
Fnum = Fnum + 1
ReDim Preserve MyFiles(1 To Fnum)
MyFiles(Fnum) = FilesInPath
FilesInPath = Dir()
Loop

'Change ScreenUpdating, Calculation and EnableEvents
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With

'Add a new workbook with one sheet
Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
rnum = 1

'Loop through all files in the array(myFiles)
If Fnum > 0 Then
For Fnum = LBound(MyFiles) To UBound(MyFiles)
Set mybook = Nothing
On Error Resume Next
Set mybook = Workbooks.Open(MyPath & MyFiles(Fnum))
On Error GoTo 0

If Not mybook Is Nothing Then

On Error Resume Next

With mybook.Worksheets(1)
Set sourceRange = .Range("H" & LastRow(mybook.Worksheets(1)))
End With

If Err.Number > 0 Then
Err.Clear
Set sourceRange = Nothing
Else
'if SourceRange use all columns then skip this file
If sourceRange.Columns.Count >= BaseWks.Columns.Count Then
Set sourceRange = Nothing
End If
End If
On Error GoTo 0

If Not sourceRange Is Nothing Then

SourceRcount = sourceRange.Rows.Count

If rnum + SourceRcount >= BaseWks.Rows.Count Then
MsgBox "Sorry there are not enough rows in the sheet"
BaseWks.Columns.AutoFit
mybook.Close savechanges:=False
GoTo ExitTheSub
Else

'Copy the file name in column A
With sourceRange
BaseWks.Cells(rnum, "A"). _
Resize(.Rows.Count).Value = MyFiles(Fnum)
End With

'Set the destrange
Set destrange = BaseWks.Range("B" & rnum)

'we copy the values from the sourceRange to the destrange
With sourceRange
Set destrange = destrange. _
Resize(.Rows.Count, .Columns.Count)
End With
destrange.Value = sourceRange.Value

rnum = rnum + SourceRcount
End If
End If
mybook.Close savechanges:=False
End If

Next Fnum
BaseWks.Columns.AutoFit
End If

ExitTheSub:
'Restore ScreenUpdating, Calculation and EnableEvents
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalcMode
End With
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

Se also
http://www.rondebruin.nl/copy3.htm





--

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


KennyD said:
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
Click to expand...
.
Click to expand...
 
R

Ron de Bruin

You see this line that autofit the columns on the new sheet

BaseWks.Columns.AutoFit

Before that line you can add your code to change the format of the sheet

For example this to make column A bold

BaseWks.Columns("A").Font.Bold = True
BaseWks.Columns.AutoFit



--

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


KennyD said:
Ron,

Where at in this macro would I enter any formatting that I might want to do
to the new worksheet?

--
Nothing in life is ever easy - just get used to that fact.


Ron de Bruin said:
If you want to find the last cell in H you must open each file.
The code example you use now will create links and not open the file


Try this for the first sheet in each workbook
Change the path to your folder here

MyPath = "C:\Users\Ron Desktop\test"


Sub Basic_Example_1()
Dim MyPath As String, FilesInPath As String
Dim MyFiles() As String
Dim SourceRcount As Long, Fnum As Long
Dim mybook As Workbook, BaseWks As Worksheet
Dim sourceRange As Range, destrange As Range
Dim rnum As Long, CalcMode As Long

'Fill in the path\folder where the files are
MyPath = "C:\Users\Ron Desktop\test"

'Add a slash at the end if the user forget it
If Right(MyPath, 1) <> "\" Then
MyPath = MyPath & "\"
End If

'If there are no Excel files in the folder exit the sub
FilesInPath = Dir(MyPath & "*.xl*")
If FilesInPath = "" Then
MsgBox "No files found"
Exit Sub
End If

'Fill the array(myFiles)with the list of Excel files in the folder
Fnum = 0
Do While FilesInPath <> ""
Fnum = Fnum + 1
ReDim Preserve MyFiles(1 To Fnum)
MyFiles(Fnum) = FilesInPath
FilesInPath = Dir()
Loop

'Change ScreenUpdating, Calculation and EnableEvents
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With

'Add a new workbook with one sheet
Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
rnum = 1

'Loop through all files in the array(myFiles)
If Fnum > 0 Then
For Fnum = LBound(MyFiles) To UBound(MyFiles)
Set mybook = Nothing
On Error Resume Next
Set mybook = Workbooks.Open(MyPath & MyFiles(Fnum))
On Error GoTo 0

If Not mybook Is Nothing Then

On Error Resume Next

With mybook.Worksheets(1)
Set sourceRange = .Range("H" & LastRow(mybook.Worksheets(1)))
End With

If Err.Number > 0 Then
Err.Clear
Set sourceRange = Nothing
Else
'if SourceRange use all columns then skip this file
If sourceRange.Columns.Count >= BaseWks.Columns.Count Then
Set sourceRange = Nothing
End If
End If
On Error GoTo 0

If Not sourceRange Is Nothing Then

SourceRcount = sourceRange.Rows.Count

If rnum + SourceRcount >= BaseWks.Rows.Count Then
MsgBox "Sorry there are not enough rows in the sheet"
BaseWks.Columns.AutoFit
mybook.Close savechanges:=False
GoTo ExitTheSub
Else

'Copy the file name in column A
With sourceRange
BaseWks.Cells(rnum, "A"). _
Resize(.Rows.Count).Value = MyFiles(Fnum)
End With

'Set the destrange
Set destrange = BaseWks.Range("B" & rnum)

'we copy the values from the sourceRange to the destrange
With sourceRange
Set destrange = destrange. _
Resize(.Rows.Count, .Columns.Count)
End With
destrange.Value = sourceRange.Value

rnum = rnum + SourceRcount
End If
End If
mybook.Close savechanges:=False
End If

Next Fnum
BaseWks.Columns.AutoFit
End If

ExitTheSub:
'Restore ScreenUpdating, Calculation and EnableEvents
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalcMode
End With
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

Se also
http://www.rondebruin.nl/copy3.htm





--

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


KennyD said:
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
Click to expand...
.
Click to expand...
Click to expand...
 
K

KennyD

Once again, thank you so much. Really do appreciate it.
--
Nothing in life is ever easy - just get used to that fact.


Ron de Bruin said:
You see this line that autofit the columns on the new sheet

BaseWks.Columns.AutoFit

Before that line you can add your code to change the format of the sheet

For example this to make column A bold

BaseWks.Columns("A").Font.Bold = True
BaseWks.Columns.AutoFit



--

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


KennyD said:
Ron,

Where at in this macro would I enter any formatting that I might want to do
to the new worksheet?

--
Nothing in life is ever easy - just get used to that fact.


Ron de Bruin said:
If you want to find the last cell in H you must open each file.
The code example you use now will create links and not open the file


Try this for the first sheet in each workbook
Change the path to your folder here

MyPath = "C:\Users\Ron Desktop\test"


Sub Basic_Example_1()
Dim MyPath As String, FilesInPath As String
Dim MyFiles() As String
Dim SourceRcount As Long, Fnum As Long
Dim mybook As Workbook, BaseWks As Worksheet
Dim sourceRange As Range, destrange As Range
Dim rnum As Long, CalcMode As Long

'Fill in the path\folder where the files are
MyPath = "C:\Users\Ron Desktop\test"

'Add a slash at the end if the user forget it
If Right(MyPath, 1) <> "\" Then
MyPath = MyPath & "\"
End If

'If there are no Excel files in the folder exit the sub
FilesInPath = Dir(MyPath & "*.xl*")
If FilesInPath = "" Then
MsgBox "No files found"
Exit Sub
End If

'Fill the array(myFiles)with the list of Excel files in the folder
Fnum = 0
Do While FilesInPath <> ""
Fnum = Fnum + 1
ReDim Preserve MyFiles(1 To Fnum)
MyFiles(Fnum) = FilesInPath
FilesInPath = Dir()
Loop

'Change ScreenUpdating, Calculation and EnableEvents
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With

'Add a new workbook with one sheet
Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
rnum = 1

'Loop through all files in the array(myFiles)
If Fnum > 0 Then
For Fnum = LBound(MyFiles) To UBound(MyFiles)
Set mybook = Nothing
On Error Resume Next
Set mybook = Workbooks.Open(MyPath & MyFiles(Fnum))
On Error GoTo 0

If Not mybook Is Nothing Then

On Error Resume Next

With mybook.Worksheets(1)
Set sourceRange = .Range("H" & LastRow(mybook.Worksheets(1)))
End With

If Err.Number > 0 Then
Err.Clear
Set sourceRange = Nothing
Else
'if SourceRange use all columns then skip this file
If sourceRange.Columns.Count >= BaseWks.Columns.Count Then
Set sourceRange = Nothing
End If
End If
On Error GoTo 0

If Not sourceRange Is Nothing Then

SourceRcount = sourceRange.Rows.Count

If rnum + SourceRcount >= BaseWks.Rows.Count Then
MsgBox "Sorry there are not enough rows in the sheet"
BaseWks.Columns.AutoFit
mybook.Close savechanges:=False
GoTo ExitTheSub
Else

'Copy the file name in column A
With sourceRange
BaseWks.Cells(rnum, "A"). _
Resize(.Rows.Count).Value = MyFiles(Fnum)
End With

'Set the destrange
Set destrange = BaseWks.Range("B" & rnum)

'we copy the values from the sourceRange to the destrange
With sourceRange
Set destrange = destrange. _
Resize(.Rows.Count, .Columns.Count)
End With
destrange.Value = sourceRange.Value

rnum = rnum + SourceRcount
End If
End If
mybook.Close savechanges:=False
End If

Next Fnum
BaseWks.Columns.AutoFit
End If

ExitTheSub:
'Restore ScreenUpdating, Calculation and EnableEvents
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalcMode
End With
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

Se also
http://www.rondebruin.nl/copy3.htm





--

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


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
Click to expand...
Click to expand...
.
Click to expand...
 
D

Don Guillett

I'm curious to know if you tried my macro to get the value of the last cell
in col H for closed wbs?

--
Don Guillett
Microsoft MVP Excel
SalesAid Software
(e-mail address removed)
KennyD said:
Once again, thank you so much. Really do appreciate it.
--
Nothing in life is ever easy - just get used to that fact.


Ron de Bruin said:
You see this line that autofit the columns on the new sheet

BaseWks.Columns.AutoFit

Before that line you can add your code to change the format of the sheet

For example this to make column A bold

BaseWks.Columns("A").Font.Bold = True
BaseWks.Columns.AutoFit



--

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


KennyD said:
Ron,

Where at in this macro would I enter any formatting that I might want
to do
to the new worksheet?

--
Nothing in life is ever easy - just get used to that fact.


:

If you want to find the last cell in H you must open each file.
The code example you use now will create links and not open the file


Try this for the first sheet in each workbook
Change the path to your folder here

MyPath = "C:\Users\Ron Desktop\test"


Sub Basic_Example_1()
Dim MyPath As String, FilesInPath As String
Dim MyFiles() As String
Dim SourceRcount As Long, Fnum As Long
Dim mybook As Workbook, BaseWks As Worksheet
Dim sourceRange As Range, destrange As Range
Dim rnum As Long, CalcMode As Long

'Fill in the path\folder where the files are
MyPath = "C:\Users\Ron Desktop\test"

'Add a slash at the end if the user forget it
If Right(MyPath, 1) <> "\" Then
MyPath = MyPath & "\"
End If

'If there are no Excel files in the folder exit the sub
FilesInPath = Dir(MyPath & "*.xl*")
If FilesInPath = "" Then
MsgBox "No files found"
Exit Sub
End If

'Fill the array(myFiles)with the list of Excel files in the folder
Fnum = 0
Do While FilesInPath <> ""
Fnum = Fnum + 1
ReDim Preserve MyFiles(1 To Fnum)
MyFiles(Fnum) = FilesInPath
FilesInPath = Dir()
Loop

'Change ScreenUpdating, Calculation and EnableEvents
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With

'Add a new workbook with one sheet
Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
rnum = 1

'Loop through all files in the array(myFiles)
If Fnum > 0 Then
For Fnum = LBound(MyFiles) To UBound(MyFiles)
Set mybook = Nothing
On Error Resume Next
Set mybook = Workbooks.Open(MyPath & MyFiles(Fnum))
On Error GoTo 0

If Not mybook Is Nothing Then

On Error Resume Next

With mybook.Worksheets(1)
Set sourceRange = .Range("H" &
LastRow(mybook.Worksheets(1)))
End With

If Err.Number > 0 Then
Err.Clear
Set sourceRange = Nothing
Else
'if SourceRange use all columns then skip this
file
If sourceRange.Columns.Count >=
BaseWks.Columns.Count Then
Set sourceRange = Nothing
End If
End If
On Error GoTo 0

If Not sourceRange Is Nothing Then

SourceRcount = sourceRange.Rows.Count

If rnum + SourceRcount >= BaseWks.Rows.Count Then
MsgBox "Sorry there are not enough rows in the
sheet"
BaseWks.Columns.AutoFit
mybook.Close savechanges:=False
GoTo ExitTheSub
Else

'Copy the file name in column A
With sourceRange
BaseWks.Cells(rnum, "A"). _
Resize(.Rows.Count).Value =
MyFiles(Fnum)
End With

'Set the destrange
Set destrange = BaseWks.Range("B" & rnum)

'we copy the values from the sourceRange to
the destrange
With sourceRange
Set destrange = destrange. _
Resize(.Rows.Count,
.Columns.Count)
End With
destrange.Value = sourceRange.Value

rnum = rnum + SourceRcount
End If
End If
mybook.Close savechanges:=False
End If

Next Fnum
BaseWks.Columns.AutoFit
End If

ExitTheSub:
'Restore ScreenUpdating, Calculation and EnableEvents
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalcMode
End With
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

Se also
http://www.rondebruin.nl/copy3.htm





--

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


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
Click to expand...
.
Click to expand...
Click to expand...
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

Create macro button 1
Ron - Summary_cells_from_Different_Workbooks_2 9
Modify RDB code with find and offset 6
Modifying Ron De Bruin's "Create summary sheet from different workbooks" 7
Trouble selecting multiple sheets using RDB code 11
Excel Data Combine 3
VBA does not work 1
GetOpen filename to open files(Workbooks) 11

Top