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" <Kstalker.1rbaqd_1119920713.8384@excelforum-nospam.com> wrote in
message news:Kstalker.1rbaqd_1119920713.8384@excelforum-nospam.com...
>
> 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" <Kstalker.1rbj2j_1119931518.4275@excelforum-nospam.com> wrote in
message news:Kstalker.1rbj2j_1119931518.4275@excelforum-nospam.com...
>
> 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" <Kstalker.1rcuah_1119992735.5403@excelforum-nospam.com> wrote in
message news:Kstalker.1rcuah_1119992735.5403@excelforum-nospam.com...
>
> 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
>

[Kstalker]

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

Thanks again.
Kristan

[Norman Jones]

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

[Kstalker]

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

Regards

Kristan

[Norman Jones]

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" <Kstalker.1rd2mj_1120003531.3279@excelforum-nospam.com> wrote in
message news:Kstalker.1rd2mj_1120003531.3279@excelforum-nospam.com...
>
> 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
>

[Kstalker]

All good.

Thanks for your knowledge and tenacity Norman.

Regards

Kristan

[Kstalker]

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

[Norman Jones]

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" <Kstalker.1s6h0t_1121375233.8371@excelforum-nospam.com> wrote in
message news:Kstalker.1s6h0t_1121375233.8371@excelforum-nospam.com...
>
> 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
>

[Kstalker]

Thanks Norman.

Works perfectly.

[Kstalker]

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

[Dave Peterson]

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