copy used range across books

[Kstalker]

I have four books that I need to bring one sheet from each into a Master book for analysis. The sheets are all in the same format and location.
I have suceeded in pulling the used range from within a workbook but not across several workbooks into one.

Can anyone help.

Thanks
Kristan

[Norman Jones]

Hi Kristan,

Try:

Option Explicit
'=========================>>
Sub TestMe()
Dim WB As Workbook, WBmain As Workbook
Dim Arr As Variant
Dim i As Long
Dim DestSh As Worksheet
Dim SrcSh As Worksheet
Dim Lrow As Long

Application.ScreenUpdating = False

Arr = Array("Book1.xls", "Book2.xls", _
"Book3.xls", "Book4.xls") '<<===== CHANGE

Set WBmain = Workbooks.Add

Set DestSh = WBmain.Worksheets(1)
DestSh.Name = "Summary"

For i = LBound(Arr) To UBound(Arr)
Set WB = Workbooks(Arr(i))
Set SrcSh = WB.Sheets("Sheet1") '<<===== CHANGE

SrcSh.UsedRange.Copy DestSh.Cells(Lrow + 1, 1)
Lrow = LastRow(DestSh)
Next
DestSh.Cells(1).Select

Application.ScreenUpdating = True

End Sub
'<<=========================

'=========================>>
Function LastRow(sh As Worksheet)
'//Function posted by Ron de Bruin
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
'<<=========================


Replace "Sheet1" with the name of the source sheet in the four workbooks.

Replace "Book1.xls"..."Book4.xls" withyour workbook names.

Consider adding a line to save the newly created summary workbook with a
name with an appended date/time so that chronologically different summary
books can readily be distinguished.

---
Regards,
Norman



"Kstalker" <[email protected]> wrote in
message news:[email protected]...
>
> I have four books that I need to bring one sheet from each into a Master
> book for analysis. The sheets are all in the same format and location.
> I have suceeded in pulling the used range from within a workbook but
> not across several workbooks into one.
>
> Can anyone help.
>
> Thanks
> Kristan
>
>
> --
> Kstalker
> ------------------------------------------------------------------------
> Kstalker's Profile:
> http://www.excelforum.com/member.php...o&userid=24699
> View this thread: http://www.excelforum.com/showthread...hreadid=382670
>

[Kstalker]

Cheers Norman.

Still falling over unfortunately, subscript out of range

Set WB = Workbooks(Arr(i))

I assume I need to reference workbook location as well.


Any Ideas??

[Norman Jones]

Hi Kristan

> Still falling over unfortunately, subscript out of range

Yes, because my code assumed that the four source workbooks were already
open.

Replace the code with the following version which does not require the
source workbooks to be open:

Option Explicit
'=========================>>
Sub TestMe()
Dim WB As Workbook, WBmain As Workbook
Dim Arr As Variant
Dim i As Long
Dim DestSh As Worksheet
Dim SrcSh As Worksheet
Dim Lrow As Long
Dim myPath As String

myPath = "C:\MyDocuments" '<<======= CHANGE

If Right(myPath, 1) <> "\" Then _
myPath = myPath & "\"

Application.ScreenUpdating = False

Arr = Array("Book1.xls", "Book2.xls", _
"Book3.xls", "Book4.xls") '<<===== CHANGE

Set WBmain = Workbooks.Add

Set DestSh = WBmain.Worksheets(1)
DestSh.Name = "Summary"

Application.DisplayAlerts = False

For i = LBound(Arr) To UBound(Arr)
Set WB = Workbooks.Open(myPath & Arr(i))
Set SrcSh = WB.Sheets("Sheet1") '<<===== CHANGE

SrcSh.UsedRange.Copy DestSh.Cells(Lrow + 1, 1)
Lrow = LastRow(DestSh)
WB.Close (False)
Next
DestSh.Cells(1).Select

With Application
.DisplayAlerts = True
.ScreenUpdating = True
End With

End Sub
'<<=========================

'=========================>>
Function LastRow(sh As Worksheet)
'//Function posted by Ron de Bruin
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
'<<=========================

In addition to the changes mentioned in my last post, change:
myPath = "C:\MyDocuments"
to the path of the four workbooks

---
Regards,
Norman



"Kstalker" <[email protected]> wrote in
message news:[email protected]...
>
> Cheers Norman.
>
> Still falling over unfortunately, subscript out of range
>
> Set WB = Workbooks(Arr(i))
>
> I assume I need to reference workbook location as well.
>
>
> Any Ideas??
>
>
> --
> Kstalker
> ------------------------------------------------------------------------
> Kstalker's Profile:
> http://www.excelforum.com/member.php...o&userid=24699
> View this thread: http://www.excelforum.com/showthread...hreadid=382670
>

[Kstalker]

Fantastic!

Cheers for that Norman it works a treat.

Another question. Is it possible to take the header row out of the used range copy for three of the sheets and not for one?

Thanks again

Kristan

[Norman Jones]

Hi Kristan

> Another question. Is it possible to take the header row out of the used
> range copy for three of the sheets and not for one?

Try:

'=========================>>
Sub TestMe2()
Dim WB As Workbook, WBmain As Workbook
Dim Arr As Variant
Dim i As Long
Dim DestSh As Worksheet
Dim SrcSh As Worksheet
Dim Lrow As Long
Dim myPath As String
Dim RngToCopy As Range

myPath = "C:\MyDocuments" '<<======= CHANGE

If Right(myPath, 1) <> "\" Then _
myPath = myPath & "\"

Application.ScreenUpdating = False

Arr = Array("Book1.xls", "Book2.xls", _
"Book3.xls", "Book4.xls") '<<===== CHANGE


Set WBmain = Workbooks.Add

Set DestSh = WBmain.Worksheets(1)
DestSh.Name = "Summary"

Application.DisplayAlerts = False

For i = LBound(Arr) To UBound(Arr)
Set WB = Workbooks.Open(myPath & Arr(i))
Set SrcSh = WB.Sheets("Sheet1") '<<===== CHANGE

With SrcSh.UsedRange
Set RngToCopy = _
.Offset(1).Resize(.Rows.Count - 1)
If i = 1 Then .Rows(1).Copy DestSh.Cells(1)
End With

RngToCopy.Copy DestSh.Cells(Lrow + 1, 1)
Lrow = LastRow(DestSh)
WB.Close (False)
Next
DestSh.Cells(1).Select

With Application
.DisplayAlerts = True
.ScreenUpdating = True
End With

End Sub
'<<=========================

'=========================>>
Function LastRow(sh As Worksheet)
'//Function posted by Ron de Bruin
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,
Norman



"Kstalker" <[email protected]> wrote in
message news:[email protected]...
>
> Fantastic!
>
> Cheers for that Norman it works a treat.
>
> Another question. Is it possible to take the header row out of the used
> range copy for three of the sheets and not for one?
>
> Thanks again
>
> Kristan
>
>
> --
> Kstalker
> ------------------------------------------------------------------------
> Kstalker's Profile:
> http://www.excelforum.com/member.php...o&userid=24699
> View this thread: http://www.excelforum.com/showthread...hreadid=382670
>