How to copy rows from 1 workbook to another workbook
I found this code and modified it...but the code keeps giving me an
error 9 message and each time I hit debug, this line is highlighted:
Set SourceRange = SourceWB.Sheets(x).Range("A49:H51")
---------
Private Sub copyMyDailyRows_Click()
Dim SourceRange As Range
Dim DestRange As Range
Dim SourceWB As Workbook
Dim SourceSh As Worksheet
Dim DestShName As String
Dim DestSh As Worksheet
Dim Lr As Long
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Dim nWS As Integer
Dim x As String
Dim y As Integer
Dim z As Integer
nWS = Me.Range("howMany").Value
'Source workbook
If bIsBookOpen_RB("wsPRIMARY.xls") Then
Set SourceWB = Workbooks("wsPRIMARY.xls")
Else
Set SourceWB = Workbooks.Open(ActiveWorkbook.Path &
"\wsPRIMARY.xls")
End If
z = 6 + nWS - 1
For y = 6 To z
Workbooks("wsSECONDARY.xls").Activate
x = ActiveWorkbook.Sheets(1).Cells(y, 2).Value
'Source range
Set SourceRange = SourceWB.Sheets(x).Range("A49:H51")
'Destination sheet
DestShName = Me.Range("whatmyName").Value
Set DestSh = ActiveWorkbook.Worksheets(DestShName)
Lr = LastRow(DestSh)
Set DestRange = DestSh.Range("A" & Lr + 3)
DestSh.Range("A" & Lr + 2).Value = x
'We make DestRange the same size as SourceRange and use the
Value
'property to give DestRange the same values
With SourceRange
Set DestRange =
DestRange.Resize(.Rows.Count, .Columns.Count)
End With
'DestRange.Value = SourceRange.Value
SourceRange.COPY
DestRange.PasteSpecial
Dim DestRange1 As Range
Dim r As Range
Set DestRange1 = DestRange.EntireRow.SpecialCells(xlFormulas)
Set r = DestRange1.Parent.Cells("50", DestRange1(1).Column)
DestRange1.Formula = "='[wsPRIMARY.xls]" & x & "'!" &
r.Address(0, 0)
Next y
SourceWB.Close savechanges:=True
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
Function bIsBookOpen_RB(ByRef szBookName As String) As Boolean
' Rob Bovey
On Error Resume Next
bIsBookOpen_RB = Not (Application.Workbooks(szBookName) Is
Nothing)
End Function
Function LastRow(sh As Worksheet)
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
Function LastCol(sh As Worksheet)
On Error Resume Next
LastCol = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
On Error GoTo 0
End Function
|