A list of excel files with complete path is entered into column A of
the workbook. Is it possible to open those files and paste the visible
rows into new excel workbook. There are more than 50 files to be
opened and pasted. One thing need to be sure while pasting, that when
second file is opened and pasted, numbers are pasted at the last row
of new excel workbook created.

Thanks in advance.

Yes this is possible

I will post a example after work tomorrow if nobody else reply.
Bed time for me now

--

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


wrote in message ...
A list of excel files with complete path is entered into column A of
the workbook. Is it possible to open those files and paste the visible
rows into new excel workbook. There are more than 50 files to be
opened and pasted. One thing need to be sure while pasting, that when
second file is opened and pasted, numbers are pasted at the last row
of new excel workbook created.

Thanks in advance.

Hi

This example will copy all data from the first worksheet in each workbook to a new workbook

Copy the macro and function in the workbook with the file names in column A in a sheet named "sheet1"
Or change the sheet name here :

For Each cell In ThisWorkbook.Sheets("Sheet1"). _
Range("A1:A100").SpecialCells(xlCellTypeConstants)

If you not want to copy the header row each time change A1 to A2 in this line
FirstCell = "A1"


Sub Basic_Example_Test()
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
Dim cell As Range
Dim FirstCell As String


'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 on Sheet1 in A1:A100
For Each cell In ThisWorkbook.Sheets("Sheet1"). _
Range("A1:A100").SpecialCells(xlCellTypeConstants)

If Dir(cell.Value) < "" Then
Set mybook = Nothing
On Error Resume Next
Set mybook = Workbooks.Open(cell.Value)

On Error GoTo 0

If Not mybook Is Nothing Then

On Error Resume Next

With mybook.Worksheets(1)
FirstCell = "A1"
Set sourceRange = .Range(FirstCell & ":" & RDB_Last(3, .Cells))
'Test if the row of the last cell = then the row of the FirstCell
If RDB_Last(1, .Cells) < .Range(FirstCell).Row Then
Set sourceRange = Nothing
End If
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 = cell.Value
End With

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

'we copy the values from the sourceRange to the destrange
sourceRange.Copy
With destrange
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
End With
rnum = rnum + SourceRcount
End If
End If
mybook.Close savechanges:=False
End If
End If
Next cell
BaseWks.Columns.AutoFit
Application.Goto BaseWks.Cells(1)

ExitTheSub:
'Restore ScreenUpdating, Calculation and EnableEvents
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalcMode
End With
End Sub

Function RDB_Last(choice As Integer, rng As Range)
'Ron de Bruin, 5 May 2008
' 1 = last row
' 2 = last column
' 3 = last cell
Dim lrw As Long
Dim lcol As Integer

Select Case choice

Case 1:
On Error Resume Next
RDB_Last = rng.Find(What:="*", _
after:=rng.Cells(1), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0

Case 2:
On Error Resume Next
RDB_Last = rng.Find(What:="*", _
after:=rng.Cells(1), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
On Error GoTo 0

Case 3:
On Error Resume Next
lrw = rng.Find(What:="*", _
after:=rng.Cells(1), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0

On Error Resume Next
lcol = rng.Find(What:="*", _
after:=rng.Cells(1), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
On Error GoTo 0

On Error Resume Next
RDB_Last = rng.Parent.Cells(lrw, lcol).Address(False, False)
If Err.Number 0 Then
RDB_Last = rng.Cells(1).Address(False, False)
Err.Clear
End If
On Error GoTo 0

End Select
End Function




--

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


wrote in message ...
A list of excel files with complete path is entered into column A of
the workbook. Is it possible to open those files and paste the visible
rows into new excel workbook. There are more than 50 files to be
opened and pasted. One thing need to be sure while pasting, that when
second file is opened and pasted, numbers are pasted at the last row
of new excel workbook created.

Thanks in advance.

Hi Ron,

Thanks for all your help so far.....need you further help on this.

For finding the last row in the worksheet to be copied from-
a) Suppose I want to find "Total" and that would be last row in the
source range. Do I need to change the "*" to "Total".
b) Second option available to me is that i would find the last row on
the basis of the end of the column. For eg. I have column A with data
from A1 to A50, then some blank rows and thereafter some more data.
Here, i would like to find out data using function something like this
"Range("A1").End(xldown).Select". I would not like to use xlup in this
case.

Hope you understand what I am trying to explain.

Can you please help me out.

Regards,
Gaurav

On Dec 6, 8:32*pm, "Ron de Bruin" wrote:
Hi

This example will copy alldatafrom the first worksheet in each workbook to a new workbook

Copy the macro and function in the workbook with the file names in column A in a sheet named "sheet1"
Or change the sheet name here :

*For Each cell In ThisWorkbook.Sheets("Sheet1"). _
* * * * Range("A1:A100").SpecialCells(xlCellTypeConstants)

If you not want to copy the header row each time change A1 to A2 in this line
*FirstCell = "A1"

Sub Basic_Example_Test()
* * 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
* * Dim cell As Range
* * Dim FirstCell As String

* * '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 on Sheet1 in A1:A100
* * For Each cell In ThisWorkbook.Sheets("Sheet1"). _
* * * * Range("A1:A100").SpecialCells(xlCellTypeConstants)

* * * * If Dir(cell.Value) < "" Then
* * * * * * Set mybook = Nothing
* * * * * * On Error Resume Next
* * * * * * Set mybook =Workbooks.Open(cell.Value)

* * * * * * On Error GoTo 0

* * * * * * If Not mybook Is Nothing Then

* * * * * * * * On Error Resume Next

* * * * * * * * With mybook.Worksheets(1)
* * * * * * * * * * FirstCell = "A1"
* * * * * * * * * * Set sourceRange = .Range(FirstCell & ":" & RDB_Last(3, .Cells))
* * * * * * * * * * 'Test if the row of the last cell = then the row of the FirstCell
* * * * * * * * * * If RDB_Last(1, .Cells) < .Range(FirstCell).Row Then
* * * * * * * * * * * * Set sourceRange = Nothing
* * * * * * * * * * End If
* * * * * * * * 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 = cell.Value
* * * * * * * * * * * * End With

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

* * * * * * * * * * * * 'we copy the values from the sourceRange to the destrange
* * * * * * * * * * * * sourceRange.Copy
* * * * * * * * * * * * With destrange
* * * * * * * * * * * * * * .PasteSpecial xlPasteValues
* * * * * * * * * * * * * * .PasteSpecial xlPasteFormats
* * * * * * * * * * * * * * Application.CutCopyMode = False
* * * * * * * * * * * * End With
* * * * * * * * * * * * rnum = rnum + SourceRcount
* * * * * * * * * * End If
* * * * * * * * End If
* * * * * * * * mybook.Close savechanges:=False
* * * * * * End If
* * * * End If
* * Next cell
* * BaseWks.Columns.AutoFit
* * Application.Goto BaseWks.Cells(1)

ExitTheSub:
* * 'Restore ScreenUpdating, Calculation and EnableEvents
* * With Application
* * * * .ScreenUpdating = True
* * * * .EnableEvents = True
* * * * .Calculation = CalcMode
* * End With
End Sub

Function RDB_Last(choice As Integer, rng As Range)
'Ron de Bruin, 5 May 2008
' 1 = last row
' 2 = last column
' 3 = last cell
* * Dim lrw As Long
* * Dim lcol As Integer

* * Select Case choice

* * Case 1:
* * * * On Error Resume Next
* * * * RDB_Last = rng.Find(What:="*", _
* * * * * * * * * * * * * * after:=rng.Cells(1), _
* * * * * * * * * * * * * * Lookat:=xlPart, _
* * * * * * * * * * * * * * LookIn:=xlFormulas, _
* * * * * * * * * * * * * * SearchOrder:=xlByRows, _
* * * * * * * * * * * * * * SearchDirection:=xlPrevious, _
* * * * * * * * * * * * * * MatchCase:=False).Row
* * * * On Error GoTo 0

* * Case 2:
* * * * On Error Resume Next
* * * * RDB_Last = rng.Find(What:="*", _
* * * * * * * * * * * * * * after:=rng.Cells(1), _
* * * * * * * * * * * * * * Lookat:=xlPart, _
* * * * * * * * * * * * * * LookIn:=xlFormulas, _
* * * * * * * * * * * * * * SearchOrder:=xlByColumns, _
* * * * * * * * * * * * * * SearchDirection:=xlPrevious, _
* * * * * * * * * * * * * * MatchCase:=False).Column
* * * * On Error GoTo 0

* * Case 3:
* * * * On Error Resume Next
* * * * lrw = rng.Find(What:="*", _
* * * * * * * * * * * *after:=rng.Cells(1), _
* * * * * * * * * * * *Lookat:=xlPart, _
* * * * * * * * * * * *LookIn:=xlFormulas, _
* * * * * * * * * * * *SearchOrder:=xlByRows, _
* * * * * * * * * * * *SearchDirection:=xlPrevious, _
* * * * * * * * * * * *MatchCase:=False).Row
* * * * On Error GoTo 0

* * * * On Error Resume Next
* * * * lcol = rng.Find(What:="*", _
* * * * * * * * * * * * after:=rng.Cells(1), _
* * * * * * * * * * * * Lookat:=xlPart, _
* * * * * * * * * * * * LookIn:=xlFormulas, _
* * * * * * * * * * * * SearchOrder:=xlByColumns, _
* * * * * * * * * * * * SearchDirection:=xlPrevious, _
* * * * * * * * * * * * MatchCase:=False).Column
* * * * On Error GoTo 0

* * * * On Error Resume Next
* * * * RDB_Last = rng.Parent.Cells(lrw, lcol).Address(False, False)
* * * * If Err.Number 0 Then
* * * * * * RDB_Last = rng.Cells(1).Address(False, False)
* * * * * * Err.Clear
* * * * End If
* * * * On Error GoTo 0

* * End Select
End Function

--

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

wrote in ...
A list of excel files with complete path is entered into column A of
the workbook. Is it possible to open those files and paste the visible
rows into new excel workbook. There are more than 50 files to be
opened and pasted. One thing need to be sure while pasting, that when
second file is opened and pasted, numbers are pasted at the last row
of new excel workbook created.

Thanks in advance.

Hi Gaurav

Start here
http://www.rondebruin.nl/last.htm

And to find a word see
http://www.rondebruin.nl/find.htm



--

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


"Gaurav" wrote in message ...
Hi Ron,

Thanks for all your help so far.....need you further help on this.

For finding the last row in the worksheet to be copied from-
a) Suppose I want to find "Total" and that would be last row in the
source range. Do I need to change the "*" to "Total".
b) Second option available to me is that i would find the last row on
the basis of the end of the column. For eg. I have column A with data
from A1 to A50, then some blank rows and thereafter some more data.
Here, i would like to find out data using function something like this
"Range("A1").End(xldown).Select". I would not like to use xlup in this
case.

Hope you understand what I am trying to explain.

Can you please help me out.

Regards,
Gaurav

On Dec 6, 8:32 pm, "Ron de Bruin" wrote:
Hi

This example will copy alldatafrom the first worksheet in each workbook to a new workbook

Copy the macro and function in the workbook with the file names in column A in a sheet named "sheet1"
Or change the sheet name here :

For Each cell In ThisWorkbook.Sheets("Sheet1"). _
Range("A1:A100").SpecialCells(xlCellTypeConstants)

If you not want to copy the header row each time change A1 to A2 in this line
FirstCell = "A1"

Sub Basic_Example_Test()
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
Dim cell As Range
Dim FirstCell As String

'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 on Sheet1 in A1:A100
For Each cell In ThisWorkbook.Sheets("Sheet1"). _
Range("A1:A100").SpecialCells(xlCellTypeConstants)

If Dir(cell.Value) < "" Then
Set mybook = Nothing
On Error Resume Next
Set mybook =Workbooks.Open(cell.Value)

On Error GoTo 0

If Not mybook Is Nothing Then

On Error Resume Next

With mybook.Worksheets(1)
FirstCell = "A1"
Set sourceRange = .Range(FirstCell & ":" & RDB_Last(3, .Cells))
'Test if the row of the last cell = then the row of the FirstCell
If RDB_Last(1, .Cells) < .Range(FirstCell).Row Then
Set sourceRange = Nothing
End If
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 = cell.Value
End With

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

'we copy the values from the sourceRange to the destrange
sourceRange.Copy
With destrange
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
End With
rnum = rnum + SourceRcount
End If
End If
mybook.Close savechanges:=False
End If
End If
Next cell
BaseWks.Columns.AutoFit
Application.Goto BaseWks.Cells(1)

ExitTheSub:
'Restore ScreenUpdating, Calculation and EnableEvents
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalcMode
End With
End Sub

Function RDB_Last(choice As Integer, rng As Range)
'Ron de Bruin, 5 May 2008
' 1 = last row
' 2 = last column
' 3 = last cell
Dim lrw As Long
Dim lcol As Integer

Select Case choice

Case 1:
On Error Resume Next
RDB_Last = rng.Find(What:="*", _
after:=rng.Cells(1), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0

Case 2:
On Error Resume Next
RDB_Last = rng.Find(What:="*", _
after:=rng.Cells(1), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
On Error GoTo 0

Case 3:
On Error Resume Next
lrw = rng.Find(What:="*", _
after:=rng.Cells(1), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0

On Error Resume Next
lcol = rng.Find(What:="*", _
after:=rng.Cells(1), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
On Error GoTo 0

On Error Resume Next
RDB_Last = rng.Parent.Cells(lrw, lcol).Address(False, False)
If Err.Number 0 Then
RDB_Last = rng.Cells(1).Address(False, False)
Err.Clear
End If
On Error GoTo 0

End Select
End Function

--

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

wrote in ...
A list of excel files with complete path is entered into column A of
the workbook. Is it possible to open those files and paste the visible
rows into new excel workbook. There are more than 50 files to be
opened and pasted. One thing need to be sure while pasting, that when
second file is opened and pasted, numbers are pasted at the last row
of new excel workbook created.

Thanks in advance.