Range of Object failure 2

[Walter349]

I cannot see where I am going wrong on this.

I have a set of workbooks, containing one worksheet (MODEL). In this worksheet are several cells I want to copy to another workbook. No problem with that.

But there is a range that starts at row A16 to E16 and extends to a changing number of rows. Selecting and copying that extensible range works OK.

My problem is pasting it to the destination workbook at the lastrow, column 5. I get the runtime error 1004 Method'range' of Object '_worksheet' failure.

Sub import_DN_Data()

Dim Bk As Workbook
Dim Sh As Worksheet, Sh1 As Worksheet
Dim rng As Range, rng1 As Range
Dim W As Variant, X As Long, Y As Variant, Z As Variant
Dim iCount As Integer
Dim LastRowA As Long

Set Sh = Workbooks("Stock despatch information 2010.xls").Worksheets("Sheet1")

Application.ScreenUpdating = False

Z = Application.GetOpenFilename(FileFilter:="Excel files (*.xls), *.xls", MultiSelect:=True)
If Not IsArray(Z) Then
    MsgBox " No Files Selected!"
    Exit Sub
End If

For X = 1 To UBound(Z)

    Set Bk = Workbooks.Open(Z(X))

    On Error Resume Next

        Set Sh1 = Bk.Worksheets("MODEL")
    
    On Error GoTo 0
    
    If Not Sh1 Is Nothing Then

        Set Sh = Workbooks("stock despatch information 2010.xls").Worksheets("Sheet1")
        
        Set rng = Sh1.Range("A1")
        Set rng1 = Sh.Cells(Rows.Count, 1).End(xlUp)(2)
        If rng.Value = "" Then
        rng.Value = "-"
            rng.Copy
            rng1.PasteSpecial xlValues
        Else
            rng.Copy
            rng1.PasteSpecial xlValues
        End If

        Set rng = Sh1.Range("B6")
        Set rng1 = Sh.Cells(Rows.Count, 2).End(xlUp)(2)
        If rng.Value = "" Then
        rng.Value = "-"
            rng.Copy
            rng1.PasteSpecial xlValues
        Else
            rng.Copy
            rng1.PasteSpecial xlValues
        End If
        
        Set rng = Sh1.Range("B7")
        Set rng1 = Sh.Cells(Rows.Count, 3).End(xlUp)(2)
        If rng.Value = "" Then
        rng.Value = "-"
            rng.Copy
            rng1.PasteSpecial xlValues
        Else
            rng.Copy
            rng1.PasteSpecial xlValues
        End If
        
        'find and copy/paste detail up to lastrow
        LastRowA = Bk.Worksheets("MODEL").Cells(Rows.Count, "A").End(xlUp).Row
        For iCount = 16 To LastRowA
            Sh1.Range(iCount, "A").EntireRow.Copy Destination:=Sh.Cells(Rows.Count, 4).End(xlUp)(2)
        Next iCount
    End If
    
    Bk.Close False

Next X

End Sub

Clearly the method I am trying to use to paste the copied data is wrong, but I cannot see why it is wrong. Can anyone point out where I am stuffing this up?

'If at first you don't succeed, then your hammer is below specifications'

 

[PHV]

I'd prefix all your Rows.Count with the proper sheet object, eg:
Set rng1 = Sh.Cells([!]Sh.[/!]Rows.Count, 2).End(xlUp)(2)

Hope This Helps, PH.
FAQ219-2884
FAQ181-2886

 

[Walter349]

I have resolved the problem, (See Below)

But does anyone have any idea, how to get rid of the clipboard dialog that now comes up each time?

        'find and copy/paste detail up to lastrow
        LastRowA = Bk.Worksheets("MODEL").Cells(Rows.Count).End(xlUp).Row
        
        Sh1.Range("A16:E16" & LastRowA).Copy
        Set rng5 = Sh.Cells(LastRowB, 5).End(xlUp)(2)
        rng5.PasteSpecial Paste:=xlValues

'If at first you don't succeed, then your hammer is below specifications'

 

[xlbo]

'find and copy/paste detail up to lastrow
LastRowA = Bk.Worksheets("MODEL").Cells(Rows.Count).End(xlUp).Row

Sh1.Range("A16:E16" & LastRowA).Copy
Set rng5 = Sh.Cells(LastRowB, 5).End(xlUp)(2)
rng5.PasteSpecial Paste:=xlValues
application.cutcopymode = false

Rgds, Geoff

We could learn a lot from crayons. Some are sharp, some are pretty and some are dull. Some have weird names and all are different colours but they all live in the same box.

Please read FAQ222-2244 before you ask a question

 

[PHV]

Anyway, I'd replace this:
Sh1.Range("A16:E16" & LastRowA).Copy
with this:
Sh1.Range("A16:E" & LastRowA).Copy

Hope This Helps, PH.
FAQ219-2884
FAQ181-2886

 

[Walter349]

Resolved, with the following.

XLBO:
Thanks for the input on the CutCopy issue for the clipboard.

PHV:
I haven't done that yet, as I have been busy going through three years worth of data, with the code as below.

Sub import_DN_Data()

Dim Bk As Workbook
Dim Sh As Worksheet, Sh1 As Worksheet
Dim rng As Range, rng1 As Range
Dim W As Variant, X As Long, Y As Variant, Z As Variant
Dim iCount As Integer
Dim LastRowA As Long

Set Sh = Workbooks("Stock despatch information 2010.xls").Worksheets("Sheet2")

Application.ScreenUpdating = False

Z = Application.GetOpenFilename(FileFilter:="Excel files (*.xls), *.xls", MultiSelect:=True)
If Not IsArray(Z) Then
    MsgBox " No Files Selected!"
    Exit Sub
End If

For X = 1 To UBound(Z)

    Set Bk = Workbooks.Open(Z(X))

    On Error Resume Next

        Set Sh1 = Bk.Worksheets("MODEL")
    
    On Error GoTo 0
    
    LastRowA = Bk.Worksheets("MODEL").Cells(Rows.Count).End(xlUp).Row
    
    With Sh
        Linetest = 2
        CellTest = Sh.Cells(Linetest, 5)
        Do Until IsEmpty(CellTest) = True
            Linetest = Linetest + 1
            CellTest = Sh.Cells(Linetest, 5)
        Loop
    End With
               
    If Not Sh1 Is Nothing Then
        Set rng = Sh1.Range("A1")
        Set rng1 = Sh.Cells(Linetest, 1)
        If rng.Value = "" Then
        rng.Value = "-"
            rng.Copy
            rng1.PasteSpecial xlValues
        Else
            rng.Copy
            rng1.PasteSpecial xlValues
        End If

        Set rng = Sh1.Range("B6")
        Set rng1 = Sh.Cells(Linetest, 2)
        If rng.Value = "" Then
        rng.Value = "-"
            rng.Copy
            rng1.PasteSpecial xlValues
        Else
            rng.Copy
            rng1.PasteSpecial xlValues
        End If
       
        Set rng = Sh1.Range("B7")
        Set rng1 = Sh.Cells(Linetest, 3)
        If rng.Value = "" Then
        rng.Value = "-"
            rng.Copy
            rng1.PasteSpecial xlValues
        Else
            rng.Copy
            rng1.PasteSpecial xlValues
        End If
        
        Set rng = Sh1.Range("A15")
        Set rng1 = Sh.Cells(Linetest, 4)
        If rng.Value = "" Then
        rng.Value = "-"
            rng.Copy
            rng1.PasteSpecial xlValues
        Else
            rng.Copy
            rng1.PasteSpecial xlValues
        End If

        'find and copy/paste detail up to lastrow
        
        Sh1.Range("A16:E16" & LastRowA).Copy
        
        Set rng1 = Sh.Cells(Linetest, 5)
        rng1.PasteSpecial Paste:=xlValues
     
    End If
    Application.CutCopyMode = False
    Bk.Close False

Next X

End Sub

'If at first you don't succeed, then your hammer is below specifications'