Ron - Summary_cells_from_Different_Workbooks_2

Hi,

I want to change the exemple of Ron: the last row of every sheet is to copy
in the summary sheet, not a static range.

I don`t know
where to add the Function LastRowDatenblatt
and
how to define the row
Set Rng = Range("A" & LastRowDatenblatt : "T" & LastRowDatenblatt)
problem: double quotes
Set Rng = Range("A177:T177"),
177 = LastRowDatenblatt of the first sheet

Thank you !
Volker


Sub Summary_cells_from_Different_Workbooks_2()
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 = "LeerW"

Set Rng = Range("A177:T177") 'Range to modify,
....LastRowDatenblatt

'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("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 in the sheet 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
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

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

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

Hi Volker

To do this you must open the files in the loop
Do you want to copy the values or create the links

--
Regards Ron de Bruin
http://www.rondebruin.nl


"Volker Hormuth" <[email protected]> wrote in message news:[email protected]...
> Hi,
>
> I want to change the exemple of Ron: the last row of every sheet is to copy in the summary sheet, not a static range.
>
> I don`t know
> where to add the Function LastRowDatenblatt
> and
> how to define the row
> Set Rng = Range("A" & LastRowDatenblatt : "T" & LastRowDatenblatt)
> problem: double quotes
> Set Rng = Range("A177:T177"),
> 177 = LastRowDatenblatt of the first sheet
>
> Thank you !
> Volker
>
>
> Sub Summary_cells_from_Different_Workbooks_2()
> 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 = "LeerW"
>
> Set Rng = Range("A177:T177") 'Range to modify, ...LastRowDatenblatt
>
> '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("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 in the sheet 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
> 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
>
> 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
>
> Function LastRowDatenblatt(sh As Worksheet)
> On Error Resume Next
> LastRowDatenblatt = sh.Cells.Find(What:="*", _
> After:=sh.Range("C1"), _
> Lookat:=xlPart, _
> LookIn:=xlFormulas, _
> SearchOrder:=xlByRows, _
> SearchDirection:=xlPrevious, _
> MatchCase:=False).Row
> On Error GoTo 0
> End Function
>
>

Try this formula example

Sub Summary_cells_from_Different_Workbooks_2()
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
Dim mybook As Workbook
Dim LRow As String

ShName = "LeerW" '<---- Change

'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("Sheet2") '<---- Change

For FNum = LBound(FileNameXls) To UBound(FileNameXls)
Set mybook = Workbooks.Open(FileNameXls(FNum))
LRow = LastRow(mybook.Sheets(ShName))
mybook.Close False
Set Rng = Range("A" & LRow & ":T" & LRow)

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 in the sheet 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
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

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



--
Regards Ron de Bruin
http://www.rondebruin.nl


"Ron de Bruin" <[email protected]> wrote in message news:[email protected]...
> Hi Volker
>
> To do this you must open the files in the loop
> Do you want to copy the values or create the links
>
> --
> Regards Ron de Bruin
> http://www.rondebruin.nl
>
>
> "Volker Hormuth" <[email protected]> wrote in message news:[email protected]...
>> Hi,
>>
>> I want to change the exemple of Ron: the last row of every sheet is to copy in the summary sheet, not a static range.
>>
>> I don`t know
>> where to add the Function LastRowDatenblatt
>> and
>> how to define the row
>> Set Rng = Range("A" & LastRowDatenblatt : "T" & LastRowDatenblatt)
>> problem: double quotes
>> Set Rng = Range("A177:T177"),
>> 177 = LastRowDatenblatt of the first sheet
>>
>> Thank you !
>> Volker
>>
>>
>> Sub Summary_cells_from_Different_Workbooks_2()
>> 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 = "LeerW"
>>
>> Set Rng = Range("A177:T177") 'Range to modify, ...LastRowDatenblatt
>>
>> '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("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 in the sheet 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
>> 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
>>
>> 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
>>
>> Function LastRowDatenblatt(sh As Worksheet)
>> On Error Resume Next
>> LastRowDatenblatt = sh.Cells.Find(What:="*", _
>> After:=sh.Range("C1"), _
>> Lookat:=xlPart, _
>> LookIn:=xlFormulas, _
>> SearchOrder:=xlByRows, _
>> SearchDirection:=xlPrevious, _
>> MatchCase:=False).Row
>> On Error GoTo 0
>> End Function
>>
>>
>
>

Note:
This macro is working now but must be changed because of you open the files now to
test the last row.
We can delete the ExecuteExcel4Macro and change more.
On this moment it blow if the sheet name not exist in the workbook.

If this macro is working correct I chnage it for you
Let me know


--
Regards Ron de Bruin
http://www.rondebruin.nl


"Ron de Bruin" <[email protected]> wrote in message news:[email protected]...
> Try this formula example
>
> Sub Summary_cells_from_Different_Workbooks_2()
> 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
> Dim mybook As Workbook
> Dim LRow As String
>
> ShName = "LeerW" '<---- Change
>
> '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("Sheet2") '<---- Change
>
> For FNum = LBound(FileNameXls) To UBound(FileNameXls)
> Set mybook = Workbooks.Open(FileNameXls(FNum))
> LRow = LastRow(mybook.Sheets(ShName))
> mybook.Close False
> Set Rng = Range("A" & LRow & ":T" & LRow)
>
> 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 in the sheet 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
> 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
>
> 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
>
>
>
> --
> Regards Ron de Bruin
> http://www.rondebruin.nl
>
>
> "Ron de Bruin" <[email protected]> wrote in message news:[email protected]...
>> Hi Volker
>>
>> To do this you must open the files in the loop
>> Do you want to copy the values or create the links
>>
>> --
>> Regards Ron de Bruin
>> http://www.rondebruin.nl
>>
>>
>> "Volker Hormuth" <[email protected]> wrote in message news:[email protected]...
>>> Hi,
>>>
>>> I want to change the exemple of Ron: the last row of every sheet is to copy in the summary sheet, not a static range.
>>>
>>> I don`t know
>>> where to add the Function LastRowDatenblatt
>>> and
>>> how to define the row
>>> Set Rng = Range("A" & LastRowDatenblatt : "T" & LastRowDatenblatt)
>>> problem: double quotes
>>> Set Rng = Range("A177:T177"),
>>> 177 = LastRowDatenblatt of the first sheet
>>>
>>> Thank you !
>>> Volker
>>>
>>>
>>> Sub Summary_cells_from_Different_Workbooks_2()
>>> 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 = "LeerW"
>>>
>>> Set Rng = Range("A177:T177") 'Range to modify, ...LastRowDatenblatt
>>>
>>> '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("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 in the sheet 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
>>> 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
>>>
>>> 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
>>>
>>> Function LastRowDatenblatt(sh As Worksheet)
>>> On Error Resume Next
>>> LastRowDatenblatt = sh.Cells.Find(What:="*", _
>>> After:=sh.Range("C1"), _
>>> Lookat:=xlPart, _
>>> LookIn:=xlFormulas, _
>>> SearchOrder:=xlByRows, _
>>> SearchDirection:=xlPrevious, _
>>> MatchCase:=False).Row
>>> On Error GoTo 0
>>> End Function
>>>
>>>
>>
>>
>
>

Hallo Ron,

thanks for your help.

In your code I have changed The LastRow-Function for column C (This row is
needed).
It isn`t copied the LastRow Column C, but 6 rows below (thats the effective
last row).`

Volker



"Ron de Bruin" <[email protected]> schrieb im Newsbeitrag
news:[email protected]...
> Note:
> This macro is working now but must be changed because of you open the
> files now to
> test the last row.
> We can delete the ExecuteExcel4Macro and change more.
> On this moment it blow if the sheet name not exist in the workbook.
>
> If this macro is working correct I chnage it for you
> Let me know
>
>
> --
> Regards Ron de Bruin
> http://www.rondebruin.nl
>
>
> "Ron de Bruin" <[email protected]> wrote in message
> news:[email protected]...
>> Try this formula example
>>
>> Sub Summary_cells_from_Different_Workbooks_2()
>> 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
>> Dim mybook As Workbook
>> Dim LRow As String
>>
>> ShName = "LeerW" '<---- Change
>>
>> '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("Sheet2") '<---- Change
>>
>> For FNum = LBound(FileNameXls) To UBound(FileNameXls)
>> Set mybook = Workbooks.Open(FileNameXls(FNum))
>> LRow = LastRow(mybook.Sheets(ShName))
>> mybook.Close False
>> Set Rng = Range("A" & LRow & ":T" & LRow)
>>
>> 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 in the sheet 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
>> 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
>>
>> 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
>>
>>
>>
>> --
>> Regards Ron de Bruin
>> http://www.rondebruin.nl
>>
>>
>> "Ron de Bruin" <[email protected]> wrote in message
>> news:[email protected]...
>>> Hi Volker
>>>
>>> To do this you must open the files in the loop
>>> Do you want to copy the values or create the links
>>>
>>> --
>>> Regards Ron de Bruin
>>> http://www.rondebruin.nl
>>>
>>>
>>> "Volker Hormuth" <[email protected]> wrote in message
>>> news:[email protected]...
>>>> Hi,
>>>>
>>>> I want to change the exemple of Ron: the last row of every sheet is to
>>>> copy in the summary sheet, not a static range.
>>>>
>>>> I don`t know
>>>> where to add the Function LastRowDatenblatt
>>>> and
>>>> how to define the row
>>>> Set Rng = Range("A" & LastRowDatenblatt : "T" & LastRowDatenblatt)
>>>> problem: double quotes
>>>> Set Rng = Range("A177:T177"),
>>>> 177 = LastRowDatenblatt of the first sheet
>>>>
>>>> Thank you !
>>>> Volker
>>>>
>>>>
>>>> Sub Summary_cells_from_Different_Workbooks_2()
>>>> 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 = "LeerW"
>>>>
>>>> Set Rng = Range("A177:T177") 'Range to modify,
>>>> ...LastRowDatenblatt
>>>>
>>>> '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("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 in the sheet 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
>>>> 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
>>>>
>>>> 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
>>>>
>>>> Function LastRowDatenblatt(sh As Worksheet)
>>>> On Error Resume Next
>>>> LastRowDatenblatt = sh.Cells.Find(What:="*", _
>>>> After:=sh.Range("C1"), _
>>>> Lookat:=xlPart, _
>>>> LookIn:=xlFormulas, _
>>>> SearchOrder:=xlByRows, _
>>>> SearchDirection:=xlPrevious, _
>>>> MatchCase:=False).Row
>>>> On Error GoTo 0
>>>> End Function
>>>>
>>>>
>>>
>>>
>>
>>
>
>

Ok

Try this one with the two functions

Sub Summary_cells_from_Different_Workbooks_3()
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
Dim mybook As Workbook
Dim LRow As String

ShName = "LeerW" '<---- Change

'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("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)

Set mybook = Workbooks.Open(FileNameXls(FNum))

If SheetExists(ShName, mybook) Then
LRow = mybook.Sheets(ShName).Range("C" & Rows.Count).End(xlUp).Row
mybook.Close False
Set Rng = Range("A" & LRow & ":T" & LRow)

'If the workbook name already exist in the sheet 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
PathStr = "'" & JustFolder & "\[" & JustFileName & "]" & ShName & "'!"

'Insert the formulas
For Each myCell In Rng.Cells
ColNum = ColNum + 1
SummWks.Cells(RwNum, ColNum).Formula = "=" & PathStr & myCell.Address
Next myCell

Else

'close workbook without saving
mybook.Close False

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

'If the sheet name not exist in the workbook the first cell color will be Yellow.
SummWks.Cells(RwNum, 1).Interior.Color = vbYellow

End If
Next FNum

' Use AutoFit for setting the column width in the new workbook
SummWks.UsedRange.Columns.AutoFit

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

Function SheetExists(SName As String, _
Optional ByVal WB As Workbook) As Boolean
'Chip Pearson
On Error Resume Next
If WB Is Nothing Then Set WB = ThisWorkbook
SheetExists = CBool(Len(WB.Sheets(SName).Name))
End Function


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


--
Regards Ron de Bruin
http://www.rondebruin.nl


"Volker Hormuth" <[email protected]> wrote in message news:%[email protected]...
> Hallo Ron,
>
> thanks for your help.
>
> In your code I have changed The LastRow-Function for column C (This row is needed).
> It isn`t copied the LastRow Column C, but 6 rows below (thats the effective last row).`
>
> Volker
>
>
>
> "Ron de Bruin" <[email protected]> schrieb im Newsbeitrag news:[email protected]...
>> Note:
>> This macro is working now but must be changed because of you open the files now to
>> test the last row.
>> We can delete the ExecuteExcel4Macro and change more.
>> On this moment it blow if the sheet name not exist in the workbook.
>>
>> If this macro is working correct I chnage it for you
>> Let me know
>>
>>
>> --
>> Regards Ron de Bruin
>> http://www.rondebruin.nl
>>
>>
>> "Ron de Bruin" <[email protected]> wrote in message news:[email protected]...
>>> Try this formula example
>>>
>>> Sub Summary_cells_from_Different_Workbooks_2()
>>> 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
>>> Dim mybook As Workbook
>>> Dim LRow As String
>>>
>>> ShName = "LeerW" '<---- Change
>>>
>>> '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("Sheet2") '<---- Change
>>>
>>> For FNum = LBound(FileNameXls) To UBound(FileNameXls)
>>> Set mybook = Workbooks.Open(FileNameXls(FNum))
>>> LRow = LastRow(mybook.Sheets(ShName))
>>> mybook.Close False
>>> Set Rng = Range("A" & LRow & ":T" & LRow)
>>>
>>> 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 in the sheet 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
>>> 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
>>>
>>> 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
>>>
>>>
>>>
>>> --
>>> Regards Ron de Bruin
>>> http://www.rondebruin.nl
>>>
>>>
>>> "Ron de Bruin" <[email protected]> wrote in message news:[email protected]...
>>>> Hi Volker
>>>>
>>>> To do this you must open the files in the loop
>>>> Do you want to copy the values or create the links
>>>>
>>>> --
>>>> Regards Ron de Bruin
>>>> http://www.rondebruin.nl
>>>>
>>>>
>>>> "Volker Hormuth" <[email protected]> wrote in message news:[email protected]...
>>>>> Hi,
>>>>>
>>>>> I want to change the exemple of Ron: the last row of every sheet is to copy in the summary sheet, not a static range.
>>>>>
>>>>> I don`t know
>>>>> where to add the Function LastRowDatenblatt
>>>>> and
>>>>> how to define the row
>>>>> Set Rng = Range("A" & LastRowDatenblatt : "T" & LastRowDatenblatt)
>>>>> problem: double quotes
>>>>> Set Rng = Range("A177:T177"),
>>>>> 177 = LastRowDatenblatt of the first sheet
>>>>>
>>>>> Thank you !
>>>>> Volker
>>>>>
>>>>>
>>>>> Sub Summary_cells_from_Different_Workbooks_2()
>>>>> 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 = "LeerW"
>>>>>
>>>>> Set Rng = Range("A177:T177") 'Range to modify, ...LastRowDatenblatt
>>>>>
>>>>> '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("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 in the sheet 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
>>>>> 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
>>>>>
>>>>> 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
>>>>>
>>>>> Function LastRowDatenblatt(sh As Worksheet)
>>>>> On Error Resume Next
>>>>> LastRowDatenblatt = sh.Cells.Find(What:="*", _
>>>>> After:=sh.Range("C1"), _
>>>>> Lookat:=xlPart, _
>>>>> LookIn:=xlFormulas, _
>>>>> SearchOrder:=xlByRows, _
>>>>> SearchDirection:=xlPrevious, _
>>>>> MatchCase:=False).Row
>>>>> On Error GoTo 0
>>>>> End Function
>>>>>
>>>>>
>>>>
>>>>
>>>
>>>
>>
>>
>
>

Do you mean

Set Rng = Range("A" & LastRowDatenblatt + 1 & " :T" & LastRowDatenblatt +
1)


--

HTH

Bob Phillips

(remove nothere from the email address if mailing direct)

"Volker Hormuth" <[email protected]> wrote in message
news:[email protected]...
> Hi,
>
> I want to change the exemple of Ron: the last row of every sheet is to
copy
> in the summary sheet, not a static range.
>
> I don`t know
> where to add the Function LastRowDatenblatt
> and
> how to define the row
> Set Rng = Range("A" & LastRowDatenblatt : "T" & LastRowDatenblatt)
> problem: double quotes
> Set Rng = Range("A177:T177"),
> 177 = LastRowDatenblatt of the first sheet
>
> Thank you !
> Volker
>
>
> Sub Summary_cells_from_Different_Workbooks_2()
> 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 = "LeerW"
>
> Set Rng = Range("A177:T177") 'Range to modify,
> ...LastRowDatenblatt
>
> '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("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 in the sheet 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
> 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
>
> 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
>
> Function LastRowDatenblatt(sh As Worksheet)
> On Error Resume Next
> LastRowDatenblatt = sh.Cells.Find(What:="*", _
> After:=sh.Range("C1"), _
> Lookat:=xlPart, _
> LookIn:=xlFormulas, _
> SearchOrder:=xlByRows, _
> SearchDirection:=xlPrevious, _
> MatchCase:=False).Row
> On Error GoTo 0
> End Function
>
>

Hallo Bob,
this wasn`t the right direction.
Ron has changed the code, now I can work with it.
Thanks for your your help.
Volker

"Bob Phillips" <[email protected]> schrieb im Newsbeitrag
news:[email protected]...
> Do you mean
>
> Set Rng = Range("A" & LastRowDatenblatt + 1 & " :T" & LastRowDatenblatt +
> 1)
>
>
> --
>
> HTH
>
> Bob Phillips
>
> (remove nothere from the email address if mailing direct)
>
> "Volker Hormuth" <[email protected]> wrote in message
> news:[email protected]...
>> Hi,
>>
>> I want to change the exemple of Ron: the last row of every sheet is to
> copy
>> in the summary sheet, not a static range.
>>
>> I don`t know
>> where to add the Function LastRowDatenblatt
>> and
>> how to define the row
>> Set Rng = Range("A" & LastRowDatenblatt : "T" & LastRowDatenblatt)
>> problem: double quotes
>> Set Rng = Range("A177:T177"),
>> 177 = LastRowDatenblatt of the first sheet
>>
>> Thank you !
>> Volker
>>
>>
>> Sub Summary_cells_from_Different_Workbooks_2()
>> 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 = "LeerW"
>>
>> Set Rng = Range("A177:T177") 'Range to modify,
>> ...LastRowDatenblatt
>>
>> '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("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 in the sheet 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
>> 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
>>
>> 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
>>
>> Function LastRowDatenblatt(sh As Worksheet)
>> On Error Resume Next
>> LastRowDatenblatt = sh.Cells.Find(What:="*", _
>> After:=sh.Range("C1"), _
>> Lookat:=xlPart, _
>> LookIn:=xlFormulas, _
>> SearchOrder:=xlByRows, _
>> SearchDirection:=xlPrevious, _
>> MatchCase:=False).Row
>> On Error GoTo 0
>> End Function
>>
>>
>
>