Re: 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 Work***
Dim DestSh As Work***
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" *** 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 *** 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 Work***)
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?action=getinfo&userid=24699
View this thread: http://www.excelforum.com/showthread.php?threadid=382670

.

Loading