Inserting Images in to excel cell from folder

user_7462639 0
Viewed 1038

i am very new to VBA program i am not sure how to perform my requirement

Here ,my requirement is In my Excel sheet having 3 columns. Column names(S.no,S,E). I want to insert the Images in to S and E columns based on the matching S.no and Image name ,All my images are in another folder .

sample input format

S.no      S         E

1       
2       
99

Images names in the folder

c:\iamges\E_001.jpg

c:\images\E_002.jpg

c:\images\S_002.jpg

c:\images\E_099.jpg

Required output format in the cells

S.no      S          E

1                    E_001.jpg

2       S_002.jpg    E_002.jpg

99                   E_099.jpg

Here S.no 1 is matching the E_001.jpg image

S.no 2 is matching the S_002.jpg and E_002.jpg images in the folder

In the similar way matching all the images and filled in to cells.

I am trying the following code

strFolder = "C:\\images" 'change the path accordingly
    If Right(strFolder, 1) <> "\" Then
        strFolder = strFolder & "\"
    End If

    Set rngCell = Range("c5") 'starting cell

    strFileName = Dir(strFolder & "E*.jpg", vbNormal) 'filter for .jpg files

    Do While Len(strFileName) > 0
        Set objPic = ActiveSheet.Pictures.Insert(strFolder & strFileName)
        With objPic
             .ShapeRange.LockAspectRatio = False
            .Left = rngCell.Left
            .Top = rngCell.Top
            .Height = rngCell.Height
            .Width = rngCell.Width
            .Placement = xlMoveAndSize
        End With
        Set rngCell = rngCell.Offset(1, 0)
        strFileName = Dir
    Loop

the above code fill all the images in to cell with out matching the filename and S.no

ms-office
1 Answers

I tried based on the reference .

Sub AddPictures()
 Dim myPic As Picture
 Dim wkSheet As Worksheet
 Dim myRng As Range
 Dim myCell As Range

 Dim rowCount2 As Long

     Set wkSheet = Sheets(2) ' -- Working sheet

    '-- The usual way of finding used row count for specific column
    rowCount2 = wkSheet.Cells(wkSheet.Rows.Count, "A").End(xlUp).Row

    If rowCount2 <> 0 Then
        Set myRng = wkSheet.Range("A2", wkSheet.Cells(wkSheet.Rows.Count, "A").End(xlUp)) 'S.no starting from cell A2

        For Each myCell In myRng.Cells
               If Len(myCell) = 1 Then
                 myCell2 = "E_00" & myCell & ".jpg"
                 myCell3 = "S_00" & myCell & ".jpg"
                 ElseIf Len(myCell) = 2 Then
                 myCell2 = "E_0" & myCell & ".jpg"
                 myCell3 = "S_0" & myCell & ".jpg"
                 Else
                 myCell2 = "E_" & myCell & ".jpg"
                 myCell3 = "S_" & myCell & ".jpg"
                 End If
                 myCell1 = "c:\iamges\\\" & myCell2

               If Trim(myCell1) = "" Then
                    MsgBox "No file path"

               ElseIf Dir(CStr(myCell1)) = "" Then

                    MsgBox "Error Image" & myCell & " Doesn't exist!"

               Else

                    Set myPic = myCell.Offset(0, 1).Parent.Pictures.Insert(myCell1)

                    With myPic '1 columns to the right of A ( is B)
                        '-- resize image here to fit into the size of your cell
                        .ShapeRange.LockAspectRatio = False
                        myPic.Top = myCell.Offset(0, 1).Top
                        myPic.Width = myCell.Offset(0, 1).Width
                        myPic.Height = myCell.Offset(0, 1).Height
                        myPic.Left = myCell.Offset(0, 1).Left
                        myPic.Placement = xlMoveAndSize
                    End With

               End If

                myCell1 = "c:\iamges\\\" & myCell3
               If Trim(myCell1) = "" Then
                    MsgBox "No file path"
               ElseIf Dir(CStr(myCell1)) = "" Then
                    MsgBox "Solution image " & myCell & " Doesn't exist!"
               Else
                    'myCell.Offset(0, 1).Parent.Pictures.Insert (myCell1)
                    Set myPic = myCell.Offset(0, 2).Parent.Pictures.Insert(myCell1)

                    With myPic '1 columns to the right of A ( is C)
                        '-- resize image here to fit into the size of your cell
                        .ShapeRange.LockAspectRatio = False
                        myPic.Top = myCell.Offset(0, 2).Top
                        myPic.Width = myCell.Offset(0, 2).Width
                        myPic.Height = myCell.Offset(0, 2).Height
                        myPic.Left = myCell.Offset(0, 2).Left
                        myPic.Placement = xlMoveAndSize
                    End With

               End If


        Next myCell

    Else
        MsgBox "File is Empty"
    End If
End Sub

Reference from the reading the image

user_74626390
Related