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) :
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: