none
VBA - Copy linked images in column A to embedded individual pictures in column N RRS feed

  • Question

  • Hi All

    I have found a macro that imports images to Excel based on the filename of pictures in a folder on my computer. This works well so I'm not looking to change this macro.

    I can then select each image in column A and copy and paste it as a picture into column N, which then embeds it into the document and enables me to send the document via e-mail including the pictures. However, this is very time consuming so it'd be great if someone could come up with a VBA code to do this automatically!

    So to summarise: 

    1) Copy cell A2
    2) Paste special -> paste as picture into cell N2
    3) Copy cell A3
    4) Paste special -> paste as picture into cell N3
    5) Repeat for the remainder of column A until it reaches a blank cell

    Thanks in advance!
    Friday, April 13, 2018 9:03 AM

Answers

  • Hello Treazon,

    Check if below code could work for you.

    Sub ImportPictures()
    Dim pictureNameColumn   As String 'column where picture name is found
    Dim picturePasteColumn  As String 'column where picture is to be pasted
    
    Dim pictureName         As String 'picture name
    Dim lastPictureRow      As Long   'last row in use where picture names are
    Dim pictureRow          As Long   'current picture row to be processed
    Dim pathForPicture      As String 'path of pictures
    
    pictureNameColumn = "B"
    picturePasteColumn = "A"
    
    pictureRow = 2 'starts from this row
    
    'error handler
    On Error GoTo Err_Handler
    
    'find row of the last cell in use in the column where picture names are
    lastPictureRow = Cells(Rows.Count, pictureNameColumn).End(xlUp).Row
    
    'stop screen updates while macro is running
    Application.ScreenUpdating = False
    pathForPicture = "S:\BEN IMAGES\"
    
    'loop till last row
    Dim rng As Range
    Dim ws As Worksheet
    Do While (pictureRow <= lastPictureRow)
        pictureName = Cells(pictureRow, "B")
        If (pictureName <> vbNullString) Then
            pictureFullName = ""
            If (Dir(pathForPicture & pictureName & ".jpg") <> vbNullString) Then
                pictureFullName = pathForPicture & pictureName & ".jpg"
            ElseIf (Dir(pathForPicture & pictureName & ".png") <> vbNullString) Then
                pictureFullName = pathForPicture & pictureName & ".png"
            ElseIf (Dir(pathForPicture & pictureName & ".bmp") <> vbNullString) Then
               pictureFullName = pathForPicture & pictureName & ".bmp"
            End If
            
            If pictureFullName = "" Then
                'picture name was there, but no such picture
                Cells(pictureRow, picturePasteColumn) = "No Picture Found"
            Else
                Set rng = Cells(pictureRow, picturePasteColumn)
                ActiveSheet.Shapes.AddPicture pictureFullName, msoFalse, msoTrue, rng.Left, rng.Top, 100#, 60#
                Set rng = Cells(pictureRow, "N")
                ActiveSheet.Shapes.AddPicture pictureFullName, msoFalse, msoTrue, rng.Left, rng.Top, 100#, 60#
            End If
        Else
        'picture name cell was blank
        End If
        'increment row count
        pictureRow = pictureRow + 1
    Loop
    
    Exit_Sub:
    Range("B10").Select
    Application.ScreenUpdating = True
    Exit Sub
    
    Err_Handler:
    MsgBox "Error encountered. " & Err.Description, vbCritical, "Error"
    GoTo Exit_Sub
    
    End Sub
    

    Best Regards,

    Terry


    MSDN Community Support
    Please remember to click "Mark as Answer" the responses that resolved your issue, and to click "Unmark as Answer" if not. This can be beneficial to other community members reading this thread. If you have any compliments or complaints to MSDN Support, feel free to contact MSDNFSF@microsoft.com.

    • Marked as answer by Treazon Tuesday, April 24, 2018 8:48 AM
    Monday, April 16, 2018 9:40 AM

All replies

  • Hi Treazon,

    I'd like to confirm:
    (a) Is there an image in cell A2 adn A3?
    (b) Paste special, what? 
    (c) Can you write code for sending an email with pictures?

    Regards,

    Ashidacchi -- http://hokusosha.com/

    Friday, April 13, 2018 9:53 AM
  • The macro is pasting in A column. Possibly if you insert one line in the macro, it can paste in N column also.

    Best Regards, Asadulla Javed

    Friday, April 13, 2018 10:20 AM
    Answerer
  • Hi Ashidacchi

    a) There is an image in cell A2 and A3 (and also an image in each cell from A4 to A200). This image was inserted using a different macro - but it seems to link the picture rather than actually inserting it into the workbook (workbook file size remains small).

    b) Paste special as picture - Click on cell A2, Ctrl+C, click on cell N2, right click, paste special, Picture (U). Repeat for row below etc. The reason I want to do this is that this method works fine if I do it line by line but it is very time consuming if I have hundreds of rows!

    c) My code-writing skills are terrible but this has nothing to do with sending an email with pictures - I am trying to send the Excel file via email, so the pictures have to be self-contained within the Excel file.

    Thanks!

    Friday, April 13, 2018 10:50 AM
  • Thanks Asadulla but this isn't the issue - the pictures being inserted into column A via the macro are still linked to the original image files (rather than actually being inserted and contained within the Excel file). I need to then copy and paste this whole column into column N as actual separate pictures rather than a linked image, so that when I send the Excel file the pictures will be included without needing to send them separately.

    Cheers!


    • Edited by Treazon Friday, April 13, 2018 11:31 AM
    Friday, April 13, 2018 10:53 AM
  • Hi Treazon,

    I will think VBA code tomorrow. Please provide your code.

    But I will not provide code to send an email or open a default messaging application, becaisd I used one day, but could not achieve what I want with Excel VBA.

    Regards,


    Ashidacchi -- http://hokusosha.com/

    Friday, April 13, 2018 11:10 AM
  • Thanks Ashidacchi

    This is the code for importing the images:

    Sub ImportPictures()
    Dim pictureNameColumn   As String 'column where picture name is found
    Dim picturePasteColumn  As String 'column where picture is to be pasted
    
    Dim pictureName         As String 'picture name
    Dim lastPictureRow      As Long   'last row in use where picture names are
    Dim pictureRow          As Long   'current picture row to be processed
    Dim pathForPicture      As String 'path of pictures
    
    pictureNameColumn = "B"
    picturePasteColumn = "A"
    
    pictureRow = 2 'starts from this row
    
    'error handler
    On Error GoTo Err_Handler
    
    'find row of the last cell in use in the column where picture names are
    lastPictureRow = Cells(Rows.Count, pictureNameColumn).End(xlUp).Row
    
    'stop screen updates while macro is running
    Application.ScreenUpdating = False
    
    pathForPicture = "S:\BEN IMAGES\"
    'loop till last row
    Do While (pictureRow <= lastPictureRow)
    
        pictureName = Cells(pictureRow, "B") 'This is the picture name
        
        'if picture name is not blank then
        If (pictureName <> vbNullString) Then
        
            'check if pic is present
            
            'Start If block with .JPG
            If (Dir(pathForPicture & pictureName & ".jpg") <> vbNullString) Then
                
                Cells(pictureRow, picturePasteColumn).Select 'This is where picture will be inserted
                ActiveSheet.Pictures.Insert(pathForPicture & pictureName & ".jpg").Select 'Path to where pictures are stored
                
                With Selection
                    .Left = Cells(pictureRow, picturePasteColumn).Left + 1#
                    .Top = Cells(pictureRow, picturePasteColumn).Top + 1#
                    .ShapeRange.LockAspectRatio = msoFalse
                    .ShapeRange.Height = 60#
                    .ShapeRange.Width = 100#
                    .ShapeRange.Rotation = 0#
                End With
            'End If block with .JPG
            
            'Start ElseIf block with .PNG
            ElseIf (Dir(pathForPicture & pictureName & ".png") <> vbNullString) Then
                
                Cells(pictureRow, picturePasteColumn).Select 'This is where picture will be inserted
                ActiveSheet.Pictures.Insert(pathForPicture & pictureName & ".png").Select 'Path to where pictures are stored
                
                With Selection
                    .Left = Cells(pictureRow, picturePasteColumn).Left
                    .Top = Cells(pictureRow, picturePasteColumn).Top
                    .ShapeRange.LockAspectRatio = msoFalse
                    .ShapeRange.Height = 60#
                    .ShapeRange.Width = 100#
                    .ShapeRange.Rotation = 0#
                End With
            'End ElseIf block with .PNG
            
            'Start ElseIf block with .BMP
            ElseIf (Dir(pathForPicture & pictureName & ".bmp") <> vbNullString) Then
                
                Cells(pictureRow, picturePasteColumn).Select 'This is where picture will be inserted
                ActiveSheet.Pictures.Insert(pathForPicture & pictureName & ".bmp").Select 'Path to where pictures are stored
                
                With Selection
                    .Left = Cells(pictureRow, picturePasteColumn).Left
                    .Top = Cells(pictureRow, picturePasteColumn).Top
                    .ShapeRange.LockAspectRatio = msoFalse
                    .ShapeRange.Height = 60#
                    .ShapeRange.Width = 100#
                    .ShapeRange.Rotation = 0#
                End With
            'End ElseIf block with .BMP
            
            Else
                'picture name was there, but no such picture
                Cells(pictureRow, picturePasteColumn) = "No Picture Found"
            End If
            
        Else
        'picture name cell was blank
        End If
        'increment row count
        pictureRow = pictureRow + 1
    Loop
    
    Exit_Sub:
    Range("B10").Select
    Application.ScreenUpdating = True
    Exit Sub
    
    Err_Handler:
    MsgBox "Error encountered. " & Err.Description, vbCritical, "Error"
    GoTo Exit_Sub
    
    End Sub

    As mentioned I don't need a code to send via e-mail, the only code that I need is to copy the pictures from column A (inserted using the above code) then paste each one as a separate image into column N.

    Many thanks!


    • Edited by Treazon Friday, April 13, 2018 11:36 AM
    Friday, April 13, 2018 11:35 AM
  • A note. Picture Insert creates link from Excel 2010. Use AddPicture of Shape method in your code. In one program you can paste in both A and N column.

    refer below link.

    Same Problem


    Best Regards, Asadulla Javed

    Friday, April 13, 2018 1:34 PM
    Answerer
  • Thanks Asadulla, I've read through that but it seems that I would need to change many parameters within the code. My coding skills are not very good... By which I mean that I don't really know how to code at all.

    I was hoping that someone would be able to write a code for me (if it's not too much trouble)!

    Friday, April 13, 2018 2:24 PM
  • From that link that you sent... This looks really similar to what I want, but it doesn't work for me:

    Sub TestLoadingPictureSoItsEmbedded()
        '
        ' Load Image1.jpg to cell E5 and make it embedded, not linked.
        '
        LoadPictureFromFileToCell Me, "C:\Temp\Image1.jpg", 5, 5, 240, 320
    End Sub
    
    Sub LoadPictureFromFileToCell(ws As Excel.Worksheet, _
                                  stFilePath As String, iRow As Long, iCol As Long, _
                                  cHeight As Double, cWidth As Double)
        Dim myPic As Excel.Picture
        
        Set myPic = ws.Pictures.Insert(stFilePath)
        
        myPic.ShapeRange.LockAspectRatio = msoFalse
        myPic.Width = cWidth
        myPic.Height = cHeight
       
        myPic.Copy
        ws.Cells(iRow, iCol).Select
        ws.PasteSpecial "Picture (JPEG)", False
        
        myPic.Delete
    End Sub

    In particular, this bit:

    myPic.Copy
        ws.Cells(iRow, iCol).Select
        ws.PasteSpecial "Picture (JPEG)", False

    Surely I just need to somehow do that for all pictures in my workbook?


    Friday, April 13, 2018 2:50 PM
  •             Cells(pictureRow, picturePasteColumn).Select 'This is where picture will be inserted
                ActiveSheet.Pictures.Insert(pathForPicture & pictureName & ".bmp").Select 'Path to where pictures are stored
                
                With Selection
                    .Left = Cells(pictureRow, picturePasteColumn).Left
                    .Top = Cells(pictureRow, picturePasteColumn).Top
                    .ShapeRange.LockAspectRatio = msoFalse
                    .ShapeRange.Height = 60#
                    .ShapeRange.Width = 100#
                    .ShapeRange.Rotation = 0#
                End With

    Above code selects one cell and then using Insert method. Then selecting the image for changing Left/Top etc.

    Update like below.

    {Function AddPicture(Filename As String, LinkToFile As MsoTriState, SaveWithDocument As MsoTriState, Left As Single, Top As Single, Width As Single, Height As Single) As Shape}

    Above is definition of AddPicture.

    Replace above with below

    -------------------------

    Dim Sh as shape

    dim rng as range

    set rng=Range("N"& picturerow)

    set sh=Activesheet.Shapes.AddPicture filename:=pathForPicture & pictureName & ".bmp",linkToFile:=0,SavewithDocument:=1,left:=rng.Left,Top:=rng.Top,height:=60#,Width:=100#)

    sh.lockaspectratio=0

    set rng=Range("A"& picturerow)

    set sh=Activesheet.Shapes.AddPicture filename:=pathForPicture & pictureName & ".bmp",linkToFile:=0,SavewithDocument:=1,left:=rng.Left,Top:=rng.Top,height:=60#,Width:=100#)

    ---------------------------

    Test above and share if any issue


    Best Regards, Asadulla Javed

    Saturday, April 14, 2018 7:35 AM
    Answerer
  • Hi Treazon,
    How is your issue? Has it been resolved?

    Ashidacchi -- http://hokusosha.com/

    Monday, April 16, 2018 2:22 AM
  • Hi Asadulla

    Thanks for getting back to me on this.

    I cannot seem to make it work though... I'm unsure which parts I need to replace. I've tried replacing the quoted code with the text you provided but it comes up with an error - 'Compile error: Invalid outside procedure'.

    Would you be able to replace the correct parts within the whole code please?

    Sub ImportPictures()
    Dim pictureNameColumn   As String 'column where picture name is found
    Dim picturePasteColumn  As String 'column where picture is to be pasted
    
    Dim pictureName         As String 'picture name
    Dim lastPictureRow      As Long   'last row in use where picture names are
    Dim pictureRow          As Long   'current picture row to be processed
    Dim pathForPicture      As String 'path of pictures
    
    pictureNameColumn = "B"
    picturePasteColumn = "A"
    
    pictureRow = 2 'starts from this row
    
    'error handler
    On Error GoTo Err_Handler
    
    'find row of the last cell in use in the column where picture names are
    lastPictureRow = Cells(Rows.Count, pictureNameColumn).End(xlUp).Row
    
    'stop screen updates while macro is running
    Application.ScreenUpdating = False
    
    pathForPicture = "S:\BEN IMAGES\"
    'loop till last row
    Do While (pictureRow <= lastPictureRow)
    
        pictureName = Cells(pictureRow, "B") 'This is the picture name
        
        'if picture name is not blank then
        If (pictureName <> vbNullString) Then
        
            'check if pic is present
            
            'Start If block with .JPG
            If (Dir(pathForPicture & pictureName & ".jpg") <> vbNullString) Then
                
                Cells(pictureRow, picturePasteColumn).Select 'This is where picture will be inserted
                ActiveSheet.Pictures.Insert(pathForPicture & pictureName & ".jpg").Select 'Path to where pictures are stored
                
                With Selection
                    .Left = Cells(pictureRow, picturePasteColumn).Left + 1#
                    .Top = Cells(pictureRow, picturePasteColumn).Top + 1#
                    .ShapeRange.LockAspectRatio = msoFalse
                    .ShapeRange.Height = 60#
                    .ShapeRange.Width = 100#
                    .ShapeRange.Rotation = 0#
                End With
            'End If block with .JPG
            
            'Start ElseIf block with .PNG
            ElseIf (Dir(pathForPicture & pictureName & ".png") <> vbNullString) Then
                
                Cells(pictureRow, picturePasteColumn).Select 'This is where picture will be inserted
                ActiveSheet.Pictures.Insert(pathForPicture & pictureName & ".png").Select 'Path to where pictures are stored
                
                With Selection
                    .Left = Cells(pictureRow, picturePasteColumn).Left
                    .Top = Cells(pictureRow, picturePasteColumn).Top
                    .ShapeRange.LockAspectRatio = msoFalse
                    .ShapeRange.Height = 60#
                    .ShapeRange.Width = 100#
                    .ShapeRange.Rotation = 0#
                End With
            'End ElseIf block with .PNG
            
            'Start ElseIf block with .BMP
            ElseIf (Dir(pathForPicture & pictureName & ".bmp") <> vbNullString) Then
                
                Cells(pictureRow, picturePasteColumn).Select 'This is where picture will be inserted
                ActiveSheet.Pictures.Insert(pathForPicture & pictureName & ".bmp").Select 'Path to where pictures are stored
                
                With Selection
                    .Left = Cells(pictureRow, picturePasteColumn).Left
                    .Top = Cells(pictureRow, picturePasteColumn).Top
                    .ShapeRange.LockAspectRatio = msoFalse
                    .ShapeRange.Height = 60#
                    .ShapeRange.Width = 100#
                    .ShapeRange.Rotation = 0#
                End With
            'End ElseIf block with .BMP
            
            Else
                'picture name was there, but no such picture
                Cells(pictureRow, picturePasteColumn) = "No Picture Found"
            End If
            
        Else
        'picture name cell was blank
        End If
        'increment row count
        pictureRow = pictureRow + 1
    Loop
    
    Exit_Sub:
    Range("B10").Select
    Application.ScreenUpdating = True
    Exit Sub
    
    Err_Handler:
    MsgBox "Error encountered. " & Err.Description, vbCritical, "Error"
    GoTo Exit_Sub
    
    End Sub


    Apologies, but I don't a lot of experience with VBA so it's difficult for me to work out which parts to replace!

    Thanks


    • Edited by Treazon Monday, April 16, 2018 9:04 AM
    Monday, April 16, 2018 8:59 AM
  • Hello Treazon,

    Check if below code could work for you.

    Sub ImportPictures()
    Dim pictureNameColumn   As String 'column where picture name is found
    Dim picturePasteColumn  As String 'column where picture is to be pasted
    
    Dim pictureName         As String 'picture name
    Dim lastPictureRow      As Long   'last row in use where picture names are
    Dim pictureRow          As Long   'current picture row to be processed
    Dim pathForPicture      As String 'path of pictures
    
    pictureNameColumn = "B"
    picturePasteColumn = "A"
    
    pictureRow = 2 'starts from this row
    
    'error handler
    On Error GoTo Err_Handler
    
    'find row of the last cell in use in the column where picture names are
    lastPictureRow = Cells(Rows.Count, pictureNameColumn).End(xlUp).Row
    
    'stop screen updates while macro is running
    Application.ScreenUpdating = False
    pathForPicture = "S:\BEN IMAGES\"
    
    'loop till last row
    Dim rng As Range
    Dim ws As Worksheet
    Do While (pictureRow <= lastPictureRow)
        pictureName = Cells(pictureRow, "B")
        If (pictureName <> vbNullString) Then
            pictureFullName = ""
            If (Dir(pathForPicture & pictureName & ".jpg") <> vbNullString) Then
                pictureFullName = pathForPicture & pictureName & ".jpg"
            ElseIf (Dir(pathForPicture & pictureName & ".png") <> vbNullString) Then
                pictureFullName = pathForPicture & pictureName & ".png"
            ElseIf (Dir(pathForPicture & pictureName & ".bmp") <> vbNullString) Then
               pictureFullName = pathForPicture & pictureName & ".bmp"
            End If
            
            If pictureFullName = "" Then
                'picture name was there, but no such picture
                Cells(pictureRow, picturePasteColumn) = "No Picture Found"
            Else
                Set rng = Cells(pictureRow, picturePasteColumn)
                ActiveSheet.Shapes.AddPicture pictureFullName, msoFalse, msoTrue, rng.Left, rng.Top, 100#, 60#
                Set rng = Cells(pictureRow, "N")
                ActiveSheet.Shapes.AddPicture pictureFullName, msoFalse, msoTrue, rng.Left, rng.Top, 100#, 60#
            End If
        Else
        'picture name cell was blank
        End If
        'increment row count
        pictureRow = pictureRow + 1
    Loop
    
    Exit_Sub:
    Range("B10").Select
    Application.ScreenUpdating = True
    Exit Sub
    
    Err_Handler:
    MsgBox "Error encountered. " & Err.Description, vbCritical, "Error"
    GoTo Exit_Sub
    
    End Sub
    

    Best Regards,

    Terry


    MSDN Community Support
    Please remember to click "Mark as Answer" the responses that resolved your issue, and to click "Unmark as Answer" if not. This can be beneficial to other community members reading this thread. If you have any compliments or complaints to MSDN Support, feel free to contact MSDNFSF@microsoft.com.

    • Marked as answer by Treazon Tuesday, April 24, 2018 8:48 AM
    Monday, April 16, 2018 9:40 AM
  • Thank you so much, this seems to work well. I'm going to do some extensive testing tomorrow so will let you know if it doesn't work, but in the meantime thanks everyone for helping!

    Also, I posted the same question on other forums and didn't even get a reply, so thanks for being so helpful.

    Cheers

    Monday, April 16, 2018 10:28 AM
  • A bit late in reply. In My earlier post I tried to highlight both replacement and old codes. Anyways Terry has implemented wonderfully.

    Best Regards, Asadulla Javed

    Monday, April 16, 2018 12:29 PM
    Answerer
  • Hello Treazon,

    What's the current state of your issue? What's the result of your testing? If it is resolved, please mark helpful reply to close the thread. If not, please feel free to follow up to let us know the current issue.

    Best Regards,

    Terry


    MSDN Community Support
    Please remember to click "Mark as Answer" the responses that resolved your issue, and to click "Unmark as Answer" if not. This can be beneficial to other community members reading this thread. If you have any compliments or complaints to MSDN Support, feel free to contact MSDNFSF@microsoft.com.

    Wednesday, April 18, 2018 5:27 AM
  • Everything seems to be working fine, thanks very much!
    Tuesday, April 24, 2018 8:49 AM