How to insert pictures in execl cells

Hewlett-packard / Compaq presario cq61 note...
August 1, 2018 at 03:49:56
Specs: Vista Home Prenium, 2.2 GHz / 1978 MB
I wish to insert pictures in given cells in excel using macros

I have data in column A representing file names in a folder. The macro takes these names in column "A" as reference to read the file from the folder and insert this file in the corresponding cell in column B. The process is looped till all the names in column "A" has been read.

See below the macro to do this that I found on the internet. I think it needs some modifications.


The problem with this macro is that the pictures from the folder are read and pasted in column "B" alright but the macro is not able to adjust the cells to accommodate the inserted photos resulting in overlapping photos.

Can some one include a subroutine to address the issues of the cell size to accommodate the pictures?

Thanks

Thomas

The macro:

Private Sub CommandButton1_Click()
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 = "A"
picturePasteColumn = "B"

pictureRow = 5 '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 = "C:\images\"
'loop till last row
Do While (pictureRow <= lastPictureRow)

pictureName = Cells(pictureRow, "A") '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
.Top = Cells(pictureRow, picturePasteColumn).Top
.ShapeRange.LockAspectRatio = msoTrue
.ShapeRange.Height = 100#
.ShapeRange.Width = 130#
.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 = msoTrue
.ShapeRange.Height = 100#
.ShapeRange.Width = 130#
.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 = msoTrue
.ShapeRange.Height = 100#
.ShapeRange.Width = 130#
.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("A10").Select
Application.ScreenUpdating = True
Exit Sub

Err_Handler:
MsgBox "Error encountered. " & Err.Description, vbCritical, "Error"
GoTo Exit_Sub

End Sub


See More: How to insert pictures in execl cells

Reply ↓  Report •

#1
August 1, 2018 at 04:47:55
A posting tip...

Using the bold tags is not the correct way to post VBA code in this forum.

Please repost your code using the pre tags as explained at the following How-To link.

Thanks!

How To Post Data or Code ---> Click Here Before Posting Data or VBA Code

message edited by DerbyDad03


Reply ↓  Report •

#2
August 2, 2018 at 03:54:23
I wish to insert pictures in given cells in excel using macros

I have data in column A representing file names in a folder. The macro takes these names in column "A" as reference to read the file from the folder and insert this file in the corresponding cell in column B. The process is looped till all the names in column "A" has been read.

See below the macro to do this that I found on the internet. I think it needs some modifications.


The problem with this macro is that the pictures from the folder are read and pasted in column "B" alright but the macro is not able to adjust the cells to accommodate the inserted photos resulting in overlapping photos.

Can some one include a subroutine to address the issues of the cell size to accommodate the pictures?

Thanks

Thomas

The macro:

Private Sub CommandButton1_Click()
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 = "A"
picturePasteColumn = "B"

pictureRow = 1 '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 = "C:\Photos 2018\"
'loop till last row
Do While (pictureRow <= lastPictureRow)

    pictureName = Cells(pictureRow, "A") '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
                .Top = Cells(pictureRow, picturePasteColumn).Top
                .ShapeRange.LockAspectRatio = msoTrue 'Point 1
                .ShapeRange.Height = 50#
                .ShapeRange.Width = 80#
                .ShapeRange.Rotation = 0#
                .Placement = xlMoveAndSize 'Point 2
            End With
        'End If block with .JPG
        
        'Start ElseIf block with .JPEG
        ElseIf (Dir(pathForPicture & pictureName & ".jpeg") <> vbNullString) Then
            
            Cells(pictureRow, picturePasteColumn).Select 
'This is where picture will be inserted
            ActiveSheet.Pictures.Insert(pathForPicture & pictureName & ".jpeg").Select 
'Path to where pictures are stored
            
            With Selection
                .Left = Cells(pictureRow, picturePasteColumn).Left
                .Top = Cells(pictureRow, picturePasteColumn).Top
                .ShapeRange.LockAspectRatio = msoTrue
                .ShapeRange.Height = 50#
                .ShapeRange.Width = 80#
                .ShapeRange.Rotation = 0#
                .Placement = xlMoveAndSize 'Point 2
            End With
        'End ElseIf block with .JPEG
        
        '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 = msoTrue
                .ShapeRange.Height = 50#
                .ShapeRange.Width = 80#
                .ShapeRange.Rotation = 0#
                .Placement = xlMoveAndSize 'Point 2
            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 = msoTrue
                .ShapeRange.Height = 50#
                .ShapeRange.Width = 80#
                .ShapeRange.Rotation = 0#
                .Placement = xlMoveAndSize 'Point 2
            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("A10").Select
Application.ScreenUpdating = True
Exit Sub

Err_Handler:
MsgBox "Error encountered. " & Err.Description, vbCritical, "Error"
GoTo Exit_Sub

End Sub


Reply ↓  Report •

#3
August 2, 2018 at 11:57:46
Thanks for reposting the code as requested.

First, let's clarify something that you said:

"read the file from the folder and insert this file in the corresponding cell in column B"

I don't know if you know this, so I've got to say it in order for the following (possible) solution to make sense: The images do not get inserted into a cell. They get pasted into the worksheet at the location specified by the top left corner of the referenced cell. That's a big difference. The images basically sit in front of the cell, not in the cell. The cell and the image remain as 2 separate objects.

You have 2 options: Pick a cell size that you like and then size the picture to match that size so that it appears to be in the cell or determine the size of each image and then set the cell size to match the image size. The image will still be in front of the cell, but it will be visually contained within the borders because the cell and image are physically the same size. In fact, you could size the image slightly smaller than the cell and offset the image such that there is some separation between the cell borders and the image. That would serve to add some separation between each image.

Take a look at the code in found in the following thread. There are 2 sets of code in the responses. The first simply sets the size of each image to a hardcoded value (100x100). With that method you decide the size of your cells and then fit the picture size to "match" the size of the cell. The "updated" code let's VBA determine the size of each individual image and then sets a row height for that specific image. As a final step the code sets the column width to match the widest image of the bunch.

https://stackoverflow.com/questions...

Let us know if that works for you.

How To Post Data or Code ---> Click Here Before Posting Data or VBA Code


Reply ↓  Report •
Related Solutions


Ask Question