Copying Range as image from multiple sheets

[AlexEE]

Hello,

Experiencing a problem with VBA.
I am trying to copy range F1:M15 from 40 worksheets and pasting it as image on Sheet1. Pictures need to be places one after another in column A. (Preferably fixed in a cell, i.e. first in A1, 2nd in A2 etc.).
Sadly I can't get my code to work. Could anyone suggest changes?

Sub CopyAsImage()
Dim ws As Worksheet
Application.ScreenUpdating = False
For Each ws In ActiveWorkbook.Worksheets
If ws.Name <> "Sheet1" Then
ws.Range("F1:M15").Copy Sheets("Sheet1").Cells(Rows.Count, "A1").End(xlUp).Offset(1)
End If
Next
Application.ScreenUpdating = True
End Sub

 

[smozgur]

Hello Alex,

Welcome to the MrExcel Forum!

You said image, so we need to use CopyPicture method to take a snapshot of the range.
I am not sure about the use case, but the sample code below will also arrange the cell height & width according to pasted image.

Following code is just a sample to give an idea. It assumes fixed source range, but can be adapted for different source range sizes.

Sub CopyAsImage()
Dim sht As Worksheet
Dim lastShape As Shape
Dim newShape As Shape
Dim strRange As String
Dim shpWidth As Integer


    strRange = "A1:C3"


    For Each sht In ThisWorkbook.Worksheets
        'Sheet1 is used to paste images, so we'll skip it
        If sht.Name <> Sheet1.Name Then
            sht.Range(strRange).CopyPicture
            If Sheet1.Shapes.Count Then
                Set lastShape = Sheet1.Shapes(Sheet1.Shapes.Count)
            End If
            Sheet1.PasteSpecial
            Set newShape = Sheet1.Shapes(Sheet1.Shapes.Count)
            If Not lastShape Is Nothing Then
                newShape.Top = lastShape.Top + lastShape.Height
                newShape.Left = lastShape.Left
            End If
            newShape.TopLeftCell.RowHeight = newShape.Height * newShape.TopLeftCell.RowHeight / newShape.TopLeftCell.Height
            'Width is different since it is shared with all images.
            shpWidth = newShape.Width * newShape.TopLeftCell.ColumnWidth / newShape.TopLeftCell.Width
            If shpWidth > newShape.TopLeftCell.ColumnWidth Then
                newShape.TopLeftCell.ColumnWidth = shpWidth
            End If
        End If
    Next sht
End Sub

 

[AlexEE]

Thanks!

I am trying to make a catalog of our tools, which would include an image and maintenance due dates (last bit that is left to figure out is the image copy). Right now every tool has its own worksheet and all the pictures are stored in one range, which has the same width, height on all sheets.

Running the code gave 2 errors:
1. "Run-time error 6 - Overflow"

on the line:​

[FONT=Calibri][SIZE=3][COLOR=#000000]newShape.TopLeftCell.RowHeight = newShape.Height * newShape.TopLeftCell.RowHeight / newShape.TopLeftCell.Height[/COLOR][/SIZE][/FONT]

2. "Run-time error 1004: Unable to set the ColumnWidth property of the Range class." on the line:

[FONT=Calibri][SIZE=3][COLOR=#000000]newShape.TopLeftCell.ColumnWidth = shpWidth
[/COLOR][/SIZE][/FONT]

Ranges have the same size on all sheets. Could this solve the problem?


Two points, that would be very helpful -
1. Copying ranges should start from the 8th worksheet. Could this be done?
2. Pasting images in cell D5 and downward.​

Ignoring these 2 errors gave this result: (Image in the red is the desired result).