Copy Screen Shot

[seacrest]

Hi,
I need some code that will copy/screenshot a range that contains a picture and paste it into another worksheet
I can get it to work using Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture however i need it to loop

eg Copy range Sheet1 L16:T20 and paste it into Sheet2 B5
Sheet1 L21:T25 and paste it into Sheet2 B10 and loop until blank

 

[EXCEL MAX]

Hello Seacrest,
see if you can do something with this...

Sub CopyPictureSelection()

    Dim vN As Long, vNPicture As Long
    Const vFirstRow = 16
    Const vNRowsSelection = 5
    
    Application.ScreenUpdating = False
    vNPicture = Sheets("Sheet1").Pictures.Count
    For vN = 0 To vNPicture - 1
        Sheets("Sheet1").Activate
        Range("L" & vFirstRow + vN * vNRowsSelection & ":" _
        & "T" & vFirstRow + vN * vNRowsSelection + vNRowsSelection - 1).Select
        Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture
        Sheets("Sheet2").Activate
        Range("B" & (vN + 1) * vNRowsSelection).Activate
        Sheets("Sheet2").Pictures.Paste.Select
    Next vN
    Application.ScreenUpdating = True
   
End Sub

 

[seacrest]

Thanks, However it doesn't copy the range i need, It copies several pictures as one and pastes them almost on top of each other in sheet2
then errors on Sheets("Sheet2").Pictures.Paste.Select

 

[Dan_W]

Hi. I tried out the code that Excel Max wrote for you - it worked fine for me.
In terms of it not copying the range that you need, is that because you only gave example ranges? What is it not capturing?
Also, the code is pasting the pictures on each row, incrementing by one. I'm guessing from your example that you want it pasted on every 5 rows? I wonder if Excel Max put it on each row (rather than skipping 4) with the view that you would just increase height of the row. If that's correct, do you still want each picture to spread over 5 rows?

 

[EXCEL MAX]

Dan_W, thank you if you tested this and you see it as right.
The code is based on ranges from example, and it's answer to related question.
I was trying to understand meaning of word "Blank" in the problem and the center of resolving is on loop.
If is this serious problem I suggest more descriptive question.

 

[seacrest]

Thanks ,
I am trying to screenshot an image that also has some textboxes near the image.
The first captured range E.g. on Sheet1 is L16:T20 5 x Rows and 9 Columns
I then need this screenshot pasted into sheet2 cell B5 E.g. paste in every 5th row

It then repeats the same sequence until blank/empty L21:T25 5 x Rows and 9 Columns
then this screenshot pasted into sheet2 cell B10

There will be data adjacent to the image in K16, K20, K26, K30 etc if there is data to copy otherwise end loop

I hope this makes things clearer and i do appreciate your help

 

[Dan_W]

Hi. Honestly, I'm still confused - so I hope this is at least close to what you want. What I've done below copies the relevant range (L16:T20, etc) on Sheet1 and pastes it to Sheet2 at B5,etc. The result is a series of unbroken, vertically connected image captures of the of the relevant area on Sheet1. You will see that there is an additional subroutine ("PAUSE") below - I included this because Excel tends to throw errors when it comes to copying images and pasting them programmatically - VBA moves too fast for Excel, so it needs pause inbetween copying and pasting.

Ordinarily, we ask that people provide a sample of the data and a picture of what it is they want the end result to look like. If there are errors, then we need to know the error number, the error text, and info about where the code broke (on what line). If this isn't what you're after, it would be very helpful if you could provide the above. Fingers crossed.

Sub CopyPictureSelection()
    Application.ScreenUpdating = False
    Dim startRow As Long, destRow As Long
    Dim targetRng As Range
    startRow = 16
    destRow = 5
    Do
        DoEvents
        Sheets("Sheet1").Activate
        Set targetRng = Sheets("Sheet1").Range("L" & startRow & ":T" & startRow + 4)
        targetRng.CopyPicture Appearance:=xlScreen, Format:=xlPicture
        Pause 1
        Sheets("Sheet2").Activate
        Range("B" & destRow).Select
        Sheets("Sheet2").Pictures.Paste
        destRow = destRow + 5
        startRow = startRow + 5
    Loop Until Sheets("Sheet1").Range("L" & startRow).Value = ""
    Application.ScreenUpdating = True
    Exit Sub
    
ErrHandler:
Pause 1
Resume Next
End Sub

Sub Pause(period As Single)
Dim t As Single
t = Timer
Do
DoEvents
Loop Until t + period < Timer
End Sub