• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

multiple picture insertion

trividha

New Member
Hi
I have been trying to insert pictures into excel where the image name would be taken from a particular column ( in this case from Column "a" ) and should get pasted to another column against corresponding cell containing the image name.

I am new to VBA and I have tried searching for codes in previous posts also but the code doesn't work for me. I have come up with the following code but he follwing code all the pictures that are present in the folder and replaces the value of column A with the image name (which is not required) :

Code:
Sub AddOlEObject()

Dim mainWorkBook As Workbook
Set mainWorkBook = ActiveWorkbook

Dim oS As Worksheet
Dim fso As Object

Set oS = ThisWorkbook.ActiveSheet

Folderpath = "C:\Users\user\Desktop\Photos & Video Jhalawar\to paste"

Set fso = CreateObject("Scripting.FileSystemObject")

Dim NoOfFiles As Integer
Dim lastrow As Long, r As Range

NoOfFiles = fso.GetFolder(Folderpath).Files.Count

Set listfiles = fso.GetFolder(Folderpath).Files
For Each a In oS.UsedRange.Columns("A")
For Each fls In listfiles
strCompFilePath = Folderpath & "\" & Trim(fls.Name)
If strCompFilePath <> "" Then
If (InStr(1, strCompFilePath, "jpg", vbTextCompare) > 1 _
Or InStr(1, strCompFilePath, "jpeg", vbTextCompare) > 1 _
Or InStr(1, strCompFilePath, "png", vbTextCompare) > 1) Then
counter = counter + 1
oS.Range("A" & counter).Value = fls.Name
oS.Range("B" & counter).ColumnWidth = 25
oS.Range("B" & counter).RowHeight = 100
oS.Range("B" & counter).Activate
Call insert(strCompFilePath, counter)
oS.Activate
End If
End If
Next
Next a
mainWorkBook.Save

End Sub

Function insert(PicPath, counter)
'MsgBox PicPath
With ActiveSheet.Pictures.insert(PicPath)
With .ShapeRange
.LockAspectRatio = msoTrue
.Width = 50
.Height = 70
End With
.Left = ActiveSheet.Range("B" & counter).Left
.Top = ActiveSheet.Range("B" & counter).Top
.Placement = 1
.PrintObject = True
End With
End Function
 

Attachments

Last edited by a moderator:

navic

Member
Try
Code:
Option Explicit

Sub InsertPicture()
'Insert picture from defined folder
Dim fPath As String, fName As String
Dim r As Range, rng As Range
Dim shpPic As Shape

Application.ScreenUpdating = False
fPath = "C:\Temp\"
Set rng = Range("A2:A" & Cells(Rows.Count, 1).End(xlUp).Row) 'in column A, name of images without extension
For Each r In rng
    On Error GoTo errHandler
    If r.Value <> "" Then
'in this case, defined format is JPG
        Set shpPic = ActiveSheet.Shapes.AddPicture(Filename:=fPath & r.Value & ".jpg", linktofile:=msoFalse, _
            savewithdocument:=msoTrue, Left:=Cells(r.Row, 2).Left, Top:=Cells(r.Row, 2).Top, Width:=-1, Height:=-1)
        With shpPic
            .LockAspectRatio = msoTrue
            If .Width > Columns(2).Width Then .Width = Columns(2).Width 'destination column B
            Rows(r.Row).RowHeight = .Height
        End With
    End If
errHandler:
If Err.Number <> 0 Then
    Debug.Print Err.Number & ", " & Err.Description & ", " & r.Value
    On Error GoTo -1
End If
Next r
Application.ScreenUpdating = True
End Sub
Another solution yu can see here
 
Top