copy used range across books
 

I have four books that I need to bring one sheet from each into a Maste
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 bu
not across several workbooks into one.

Can anyone help.

Thanks
Krista

--
Kstalke
-----------------------------------------------------------------------
Kstalker's Profile: http://www.excelforum.com/member.php...fo&userid=2469
View this thread: http://www.excelforum.com/showthread.php?threadid=38267

copy used range across books
 

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" wrote in
message ...

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

copy used range across books
 

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

copy used range across books
 

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" wrote in
message ...

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

copy used range across books
 

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

copy used range across books
 

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" wrote in
message ...

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

copy used range across books
 

Hi Kristan

In Sub TestMe2() I have assumed that the one header row to be copied is the
header row from the first workbook.

If this is not so, post back.

---
Regards,
Norman

copy used range across books
 

Outstanding.
Works perfectly thanks Norman.
Will now try and apply the same function to a range of specifie
worksheets within a single workbook. The 'summary' spreadsheet bein
created in the same workbook as the information copied.
Already Posted another thread asking about this...tisk tisk.

Thanks again.
Krista

--
Kstalke
-----------------------------------------------------------------------
Kstalker's Profile: http://www.excelforum.com/member.php...fo&userid=2469
View this thread: http://www.excelforum.com/showthread.php?threadid=38267

copy used range across books
 

Assumed correctly, although I just noticed SubTest2() is taking the
header but missing the first line of data from the first worksheet.

Regards

Kristan


--
Kstalker
------------------------------------------------------------------------
Kstalker's Profile: http://www.excelforum.com/member.php...o&userid=24699
View this thread: http://www.excelforum.com/showthread...hreadid=382670

copy used range across books
 

Hi Kristan,

Try:

'=========================
Sub TestMe2A()
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 = 0 Then .Rows(1).Copy DestSh.Cells(1)
End With

LRow = LastRow(DestSh)
RngToCopy.Copy DestSh.Cells(LRow + 1, 1)

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
'<<=========================


As in your other question thread, the value of i has been changed from 1 to
0 to reflect the fact that the workbooks are held in a 0-based array) and I
have altered the position of the line:

LRow = LastRow(DestSh)

---
Regards,
Norman



"Kstalker" wrote in
message ...

Assumed correctly, although I just noticed SubTest2() is taking the
header but missing the first line of data from the first worksheet.

Regards

Kristan


--
Kstalker
------------------------------------------------------------------------
Kstalker's Profile:
http://www.excelforum.com/member.php...o&userid=24699
View this thread: http://www.excelforum.com/showthread...hreadid=382670

copy used range across books
 

All good.

Thanks for your knowledge and tenacity Norman.

Regards

Kristan


--
Kstalker
------------------------------------------------------------------------
Kstalker's Profile: http://www.excelforum.com/member.php...o&userid=24699
View this thread: http://www.excelforum.com/showthread...hreadid=382670

copy used range across books
 

Back again on this code.

The code works perfectly Norman but i have to change the way it work
slightly.

Instead of copying sheets out of the four files specified I need t
copy a single sheet out of every workbook in one folder. Again copyin
the used range and offsetting in all but the first sheet copied.

Have tried to use some code posted but no success

All help appreciate

--
Kstalke
-----------------------------------------------------------------------
Kstalker's Profile: http://www.excelforum.com/member.php...fo&userid=2469
View this thread: http://www.excelforum.com/showthread.php?threadid=38267

copy used range across books
 

Hi Kristan,

Try:

'=========================
Sub CopySheetFromAll()
Dim srcWB As Workbook, destWB As Workbook
Dim sName As String
Dim MyFiles() As String
Dim i As Long
Dim DestSh As Worksheet
Dim SrcSh As Worksheet
Dim LRow As Long
Dim sPath As String
Dim RngToCopy As Range
Dim sSaveAsName As String

sPath = "C:\MYDIR" '<<==== CHANGE

sSaveAsName = Application.DefaultFilePath _
& "\" & "MySummary " & Format _
(Date, "yyyy-mm-dd") '<<==== CHANGE

If Right(sPath, 1) < "\" Then
sPath = sPath & "\"
End If

sName = Dir(sPath & "*.xls")
If sName = "" Then
MsgBox "No files found"
Exit Sub
End If

On Error GoTo Cleanup

Application.ScreenUpdating = False

Set destWB = Workbooks.Add
Set DestSh = destWB.Worksheets(1)

DestSh.Name = "Summary"

i = 0
Do While sName < ""
i = i + 1
ReDim Preserve MyFiles(1 To i)
MyFiles(i) = sName
sName = Dir()
Loop

For i = LBound(MyFiles) To UBound(MyFiles)
Set srcWB = Workbooks.Open(sPath & MyFiles(i))

Set SrcSh = srcWB.Sheets("Sheet1") '<<===== CHANGE

With SrcSh.UsedRange
On Error Resume Next
Set RngToCopy = _
.Offset(1).Resize(.Rows.Count - 1)
On Error GoTo Cleanup
If i = 1 Then .Rows(1).Copy DestSh.Cells(1)
End With

LRow = LastRow(DestSh)

If Not RngToCopy Is Nothing Then
RngToCopy.Copy DestSh.Cells(LRow + 1, 1)
End If

srcWB.Close (False)
Set RngToCopy = Nothing
Next
DestSh.Cells(1).Select

Application.DisplayAlerts = True
destWB.SaveAs sSaveAsName
Cleanup:
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
'<<=========================


Change the value of sPath to that of the folder holding the files to be
summarised.

If the name of the worksheets to be copied is other than "Sheet1", alter the
Set srcSheet line accordingly.

Change the value of sSaveAsName to a name for the new summary workbook that
suits your purposes.

---
Regards,
Norman



"Kstalker" wrote in
message ...

Back again on this code.

The code works perfectly Norman but i have to change the way it works
slightly.

Instead of copying sheets out of the four files specified I need to
copy a single sheet out of every workbook in one folder. Again copying
the used range and offsetting in all but the first sheet copied.

Have tried to use some code posted but no success

All help appreciated


--
Kstalker
------------------------------------------------------------------------
Kstalker's Profile:
http://www.excelforum.com/member.php...o&userid=24699
View this thread: http://www.excelforum.com/showthread...hreadid=382670

copy used range across books
 

Thanks Norman.

Works perfectly.


--
Kstalker
------------------------------------------------------------------------
Kstalker's Profile: http://www.excelforum.com/member.php...o&userid=24699
View this thread: http://www.excelforum.com/showthread...hreadid=382670

copy used range across books
 

Hello all

I Started this thread some time ago and have had no issues with the
code, but recently it has started crashing. I am absolutely stumped as
to what has changed and what is causing the problem. The code is
failing at:

Set RngToCopy = .Offset(1).Resize(.Rows.Count - 1)



If anybody has a minute could you have a quick look and point out what
is hopefully glearingly obvious.

Thanks in advance
Kristan


' sequence below copies usedrange from within specified worksheets from
within active workbook

Sub CopyUsedRange()
Dim sh As Worksheet
Dim DestSh As Worksheet
Dim Last As Long
Dim RngToCopy As Range
Dim Arr As Variant
Dim Wb As Workbook

Application.ScreenUpdating = True
Application.StatusBar = "Updating Master Data..... ..... ... "

Set Wb = ActiveWorkbook

Arr = Array("NM 1", "NM 2", "NM 3", "NM 4", "NM 5", "NM 6", "NM 7", "NM
8", "BSC 1", "BSC 2", "BSC 3", "BSC 4", "BSC 5", "BSC 6") '<<==== CHANGE
if worksheets added
'Arr = Array("NM 2", "NM 3", "BSC 1") '<<==== CHANGE if worksheets
added

'deletes "master" sheet ready for fresh import
Worksheets("master").UsedRange.Offset(1).Clear

'Application.DisplayAlerts = False
'Sheets("Master").Select
'ActiveWindow.SelectedSheets.Delete
'Application.DisplayAlerts = True

'If SheetExists("Master", Wb) = True Then '<<===== CHANGE if worksheet
relabelled
'MsgBox "The sheet Master already exist"
'Exit Sub
'End If

' compiles all stage clearance data

Application.ScreenUpdating = False
Set DestSh = Wb.Worksheets("master")

For i = LBound(Arr) To UBound(Arr)
Set sh = Sheets(Arr(i))

With sh.UsedRange

If i = 0 Then .Rows(1).Copy DestSh.Cells(1)

Set RngToCopy = .Offset(1).Resize(.Rows.Count - 1)
If i = 0 Then .Rows(1).Copy DestSh.Cells(1)

End With

If sh.UsedRange.Count 1 Then
Last = LastRow(DestSh)
RngToCopy.Copy DestSh.Cells(Last + 1, 1)
End If

Next

Worksheets("navigation").Select '<<===== CHANGE if worksheet
relabelled

Application.StatusBar = False
Application.ScreenUpdating = False

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

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


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


--
Kstalker
------------------------------------------------------------------------
Kstalker's Profile: http://www.excelforum.com/member.php...o&userid=24699
View this thread: http://www.excelforum.com/showthread...hreadid=382670

copy used range across books
 

Just a guess...

If the sh.usedrange is just on row 1 (an empty sheet or really only row 1 is
used), then

with sh.usedrange
Set RngToCopy = .Offset(1).Resize(.Rows.Count - 1)
end with

Will try to resize the range to 0 rows. That can cause a problem.

Maybe you could check:

with sh.usedrange
if .rows.count = 1 then
'skip this sheet or what??
else
Set RngToCopy = .Offset(1).Resize(.Rows.Count - 1)
end if
end with

(I dropped some of your surrounding code--be careful.)

Kstalker wrote:

Hello all

I Started this thread some time ago and have had no issues with the
code, but recently it has started crashing. I am absolutely stumped as
to what has changed and what is causing the problem. The code is
failing at:

Set RngToCopy = .Offset(1).Resize(.Rows.Count - 1)

If anybody has a minute could you have a quick look and point out what
is hopefully glearingly obvious.

Thanks in advance
Kristan

' sequence below copies usedrange from within specified worksheets from
within active workbook

Sub CopyUsedRange()
Dim sh As Worksheet
Dim DestSh As Worksheet
Dim Last As Long
Dim RngToCopy As Range
Dim Arr As Variant
Dim Wb As Workbook

Application.ScreenUpdating = True
Application.StatusBar = "Updating Master Data..... ..... ... "

Set Wb = ActiveWorkbook

Arr = Array("NM 1", "NM 2", "NM 3", "NM 4", "NM 5", "NM 6", "NM 7", "NM
8", "BSC 1", "BSC 2", "BSC 3", "BSC 4", "BSC 5", "BSC 6") '<<==== CHANGE
if worksheets added
'Arr = Array("NM 2", "NM 3", "BSC 1") '<<==== CHANGE if worksheets
added

'deletes "master" sheet ready for fresh import
Worksheets("master").UsedRange.Offset(1).Clear

'Application.DisplayAlerts = False
'Sheets("Master").Select
'ActiveWindow.SelectedSheets.Delete
'Application.DisplayAlerts = True

'If SheetExists("Master", Wb) = True Then '<<===== CHANGE if worksheet
relabelled
'MsgBox "The sheet Master already exist"
'Exit Sub
'End If

' compiles all stage clearance data

Application.ScreenUpdating = False
Set DestSh = Wb.Worksheets("master")

For i = LBound(Arr) To UBound(Arr)
Set sh = Sheets(Arr(i))

With sh.UsedRange

If i = 0 Then .Rows(1).Copy DestSh.Cells(1)

Set RngToCopy = .Offset(1).Resize(.Rows.Count - 1)
If i = 0 Then .Rows(1).Copy DestSh.Cells(1)

End With

If sh.UsedRange.Count 1 Then
Last = LastRow(DestSh)
RngToCopy.Copy DestSh.Cells(Last + 1, 1)
End If

Next

Worksheets("navigation").Select '<<===== CHANGE if worksheet
relabelled

Application.StatusBar = False
Application.ScreenUpdating = False

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

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

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

--
Kstalker
------------------------------------------------------------------------
Kstalker's Profile: http://www.excelforum.com/member.php...o&userid=24699
View this thread: http://www.excelforum.com/showthread...hreadid=382670

--

Dave Peterson