copy worksheet values & picture to new workbook 1

[blackduck]

Can copy values and formats but get 'script out of range' error when I try to copy the picture (logo) across to the new workbook. Please help, its driving me nuts.

This is my code:

Private Sub cmdEmailVersion_Click()
Dim Today, fname
Application.ScreenUpdating = False
'copy to new workbook (create, name, save and close new workbook)
fname = ActiveWorkbook.Path & "\" & "email" & "\"
Today = Date$
fname = fname & "KN " & Format(Now(), "yyyymmdd") & ".xls"
Cells.Select
Selection.Copy
Workbooks.Add
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
ActiveWorkbook.Colors = Workbooks("KPINetwork.xls").Colors

Windows("KN.xls").Activate
ActiveSheet.Shapes("Picture 57").Select
Selection.ShapeRange.IncrementTop -0.75
Application.CutCopyMode = False
Selection.Copy
Windows("fname").Activate ''ERROR OCCURS HERE - SUBSCRIPT OUT OF RANGE
Range("B2").Select
ActiveSheet.Paste
Range("J11").Select

ActiveWorkbook.SaveAs FileName:=fname
ActiveWorkbook.Close
Sheets("Summary").Select
Range("J11").Select
End Sub

 

[SkipVought]

Hi,

All this Activating and Selecting is UNNECESSARY and often counter-productive.

How Can I Make My Code Run Faster? faq707-4105

Private Sub cmdEmailVersion_Click()
    Dim Today, fname, wsThis As Worksheet, wbNew As Workbook
    
    Application.ScreenUpdating = False
    'copy to new workbook (create, name, save and close new workbook)
    fname = ActiveWorkbook.Path & "\" & "email" & "\"
    
    fname = fname & "KN " & Format(Date, "yyyymmdd") & ".xls"
    
    Set wsThis = ActiveSheet
    Set wbNew = Workbooks.Add
    
    wsThis.Cells.Copy
    With wbNew
        With .Sheets(1)
            .PasteSpecial _
                Paste:=xlPasteValues, _
                Operation:=xlNone, _
                SkipBlanks:=False, _
                Transpose:=False
            .PasteSpecial _
                Paste:=xlPasteFormats, _
                Operation:=xlNone, _
                SkipBlanks:=False, _
                Transpose:=False
        End With
        .Colors = Workbooks("KPINetwork.xls").Colors
    End With
    
    wsThis.Shapes("Picture 57").Copy
    
    With wbNew
        .Sheets(1).Range("B2").Paste
    
        .SaveAs Filename:=fname
        .Close
    End With
    
    Sheets("Summary").Select
    Range("J11").Select
    Application.ScreenUpdating = True
End Sub

Skip,

_[red][/red]

 

[blackduck]

Thanks heaps Skip - this looks so much better.

When I run your code I get the error 'run-time error 1004 - application-defined or object-defined error.'

This happens when it gets to the line .PasteSpecial

any ideas?

thanks

 

[SkipVought]

I'm guessing that you are pasting at A1 on the sheet in the new workbook...

...
    With wbNew
        With .Sheets(1).[A1]
...

Skip,

_[red][/red]

 

[blackduck]

Now when it gets to the line:
.Sheets(1).Range("B2").Paste
'run-time error 438 - object doesn't support this object or method.'

I tried the following code but still get the '438' error.
With wbNew
With .Sheets(1).[B2]
.Paste
End With
.SaveAs FileName:=fname
.Close
End With

I did manage to get it working with the following nasty code:
With wbNew
.Sheets(1).Range("B2").Select
ActiveSheet.Paste
.Sheets(1).Range("J11").Select
.SaveAs FileName:=fname
.Close
End With

Dont really want to use my nasty code. Could you let me know how to write it properly?

thanks again
k

 

[SkipVought]

Since a SHEET OBJECT worked, and I should have checked that out...

    With wbNew
        With .Sheets(1)
            .Paste
        End With
         .SaveAs FileName:=fname
        .Close
    End With

If the pic is not in the position you want (I assume it would be relative to a cell), let's say you wanted it relative to the top left corner of B2...

    With wbNew
        With .Sheets(1)
            .Paste
            with .shapes(.shapes.count)
               .top = [B2].top
               .left = [B2].left
            end with
        End With
         .SaveAs FileName:=fname
        .Close
    End With

I could have assumed that this was Shape 1. But here's an illustration of adding a shape to the shapes collection on a sheet, followed by doing stuff to THAT shape.

BTW, the leftmost DOT in with .shapes(.shapes.count), refers to a previous WITH statement, in this case With .Sheets(1) which refers to wbNew.

Skip,

_[red][/red]

 

[blackduck]

Hi Skip

Thanks soo much, it works a treat!
and thanks for taking time to explain as well.

a star to ya
k