Get Imahes From a range

[crazyeyeschase]

I am wanting to copy a range of images from one WB to another.

I am going to try to explain this as best as i can .

WB1 for example is the WB with the images and WB2 is where the images need to be copied to.

Inside of WB2 i have the Cells set so A1:A6 contain the Picture name and B1:B6 is where i want the pictures copied.

Example:

Inside WB1 is the exact same setup but it included the images

Example:

This is the Code i have came up with to get at least one image to be copied

Sub GetPics()
Dim PicRange As Range
Dim PicName As String
Set PicRange = Range("A1")
PicName = PicRange

Application.ScreenUpdating = False
Application.Workbooks.Open (ThisWorkbook.Path & _
     Application.PathSeparator & "Test2.xlsm")


    Sheets("Pictures").Select
    ActiveSheet.Shapes.Range(Array(PicName)).Select
    Selection.Copy
    Windows("Test1.xlsm").Activate
    Range("B1").Select
    ActiveSheet.Paste
    
    MsgBox "IMG Copied"

     
Workbooks("Test2.xlsm").Activate
ActiveWorkbook.Save
ActiveWorkbook.Close
Application.ScreenUpdating = True
End Sub

This works fine however i am wanting the macro to get the value/text from each cell in A1:A6 and use that value as the picture name and then paste each picture in the correct position from B1:b6.

I am sorry if i didnt explain this good enough. This is just a test swatch when/if i get this figured out it will be for a much larger project.

 

[Andrew Poulsom]

Well B3:D5 is 9 cells, while A1:A6 is 6 cells. So where do you want to put the copied pictures?

 

[crazyeyeschase]

I have
B3:B4 merged
B5:B6 merged

and the same with column C and D so their is actualey only 6 Cells

Its not being used for the same code just trying to manipulate things and figure out how i can do it. I have dont a bit of searching and checked some of my other codes but since the images behave differently then normal cells its a little more confusing for myself.

If you can adjust the first code to work with these 6 (merged) cells i am sure i can play around and figure it out.

 

[Andrew Poulsom]

VBA and merged cells don't get on, but try:

Sub GetPics()
    Dim wb As Workbook
    Dim PicRange As Range
    Dim PicName As String
    Dim Cell As Range
    Dim r As Long
    Dim c As Long
    Set PicRange = Range("A1:A6")
    Application.ScreenUpdating = False
    Set wb = Application.Workbooks.Open(ThisWorkbook.Path & Application.PathSeparator & "Test2.xlsm")
    ThisWorkbook.Activate
    r = 3
    c = 2
    For Each Cell In PicRange
        PicName = Cell.Value
        wb.Sheets("Pictures").Shapes(PicName).Copy
        Cells(r, c).Select
        If r = 3 Then
            r = r + 2
        Else
            r = 3
            c = c + 1
        End If
        ActiveSheet.Paste
    Next Cell
    MsgBox "IMG Copied"
    wb.Close SaveChanges:=True
    Application.ScreenUpdating = True
End Sub