Copying Range as image from multiple sheets

AlexEE

New Member
Joined
Feb 11, 2019
Messages
2
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
 

Excel Facts

Copy PDF to Excel
Select data in PDF. Paste to Microsoft Word. Copy from Word and paste to Excel.
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.

Code:
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
 
Upvote 0
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:
Code:
[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:
Code:
[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).
2dc0d641dcd867aa145d69f155805424-full.png
 
Upvote 0

Forum statistics

Threads
1,213,501
Messages
6,114,010
Members
448,543
Latest member
MartinLarkin

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top