Bug Fixing: Copied images in Excel VBA appear as blank images

Question

The program I have been writing reads information from various sources in the workbook, rearranges the information into several compact tables on separate sheets, and then copies those tables as images into a separate summary sheet. I have written this program as several different sub routines that are called on by the main program.

When the main program runs, the images it pastes into the summary sheet have the correct dimensions and placement, but they are completely white. However, when I run the sub routine responsible for copying those images over, it succeeds in actually copying the correct tables. Here is the code I am using to copy and past the tables, as images:

Sub ExtractToPresentation()

Call UnprotectAll

Application.DisplayAlerts = False

Application.CutCopyMode = False

startcell = Worksheets("Supplier Comparison").Cells(1, 1).Address
bottomcell = Worksheets("Supplier Comparison").Cells(21, 14).Address

Set copyrng = Worksheets("Supplier Comparison").Range(startcell, bottomcell) '.SpecialCells(xlCellTypeVisible)

copyrng.CopyPicture xlScreen, xlBitmap

With Worksheets("Presentation")

    .Paste _
        Destination:=.Range(SupSt)

End With

The sub routine continues, but the rest is a variation on the above code for each additional table:

startcell = Worksheets("Rating Criteria").Cells(1, 1).Address
bottomcell = Worksheets("Rating Criteria").Cells(12, 7).Address

Set copyrng = Worksheets("Rating Criteria").Range(startcell, bottomcell)
copyrng.CopyPicture xlScreen, xlBitmap

With Worksheets("Presentation")

    .Paste _
        Destination:=.Range(CritSt)

End With

startcell = Worksheets("Comments").Cells(1, 1).Address
bottomcell = Worksheets("Comments").Cells(4, 14).Address

Set copyrng = Worksheets("Comments").Range(startcell, bottomcell)

copyrng.CopyPicture xlScreen, xlBitmap

With Worksheets("Presentation")

    .Paste _
        Destination:=.Range(CommSt)

End With

startcell = Worksheets("Component Table").Cells(1, 1).Address
bottomcell = Worksheets("Component Table").Cells(CompH, CompW).Address

Set copyrng = Worksheets("Component Table").Range(startcell, bottomcell)

copyrng.CopyPicture xlScreen, xlBitmap

With Worksheets("Presentation")

    .Paste _
        Destination:=.Range(CompSt)

End With

Application.DisplayAlerts = False

Call ProtectAll

End Sub

The variables ending in St, H, and W are defined in a previous program that determines the size of each table. I have no idea why this program functions perfectly on its own, but returns blank images when run after other programs.

Let me know if anyone wants to look at other parts of my code. There are ~500 lines in this program, and I didn't want to dump everything all at once.

Answer 1

Try

Range(*source*).Copy                           ' full source range

' asume you have a destination cell as a range
*destination*.Parent.Select                    ' select sheet
*destination*.Select                           ' select dest cell
*destination*.Parent.Pictures.Paste            ' paste

If you need to resize the image, use

*sheet*.Shapes(x).Height
*sheet*.Shapes(x).Width

working example:

Sub Test()
    Set src = Sheets("Sheet1").Range("A1", "B4")
    Set dst = Sheets("Sheet2").[C5]
    src.Copy
    dst.Parent.Select
    dst.Select
    dst.Parent.Pictures.Paste
    src.Parent.Select
    src.Select
End Sub