am working on 100 workbooks, how can I import a different photo per workbook using macro. I have named the photos according to the workbook titles already . please help
lintruthy,
In a new workbook, maybe named 'TEST2', the code could create a list of picture file names including the complete path, then open your Excel workbooks one at a time and insert the picture with the same name from that list, save the workbook, then move to the next workbook.
Typically photos (pictures) are jpg file type. So to compare the Excel workbook name with the photo file name we have to remove the file types and compare just the names. I used three formulae in helper cells to accomplish this on Sheet1 of workbook TEST2:
cell I1 =TRIM(RIGHT(SUBSTITUTE(A1,"",REPT(" ",50)),50)) 'To get just the filename without the path
'The code will copy this formula to each file listed.
cell N1 =LEFT(L1, FIND(".", L1) - 1) 'Removes the file extension '.jpg' or whatever
cell P1 = LEFT(O1, FIND(".", O1) - 1) 'Removes the file extension '.xlsm, .xlsx, or .xls'
Copy the code below into a standard module of workbook TEST2 using Alt+F11, then close and save the workbook as macro enabled. The code assumes your Excel workbooks are all in one folder, and all the photos are in another. Try on a sample copy of your workbooks in a different folder to avoid losing any data.
Good luck!
Perpa
Code:
Sub AddOlEObject()
Dim mainWorkBook As Workbook
Dim counter, rw, LR As Long
Dim nm1, nm2 As String
Application.ScreenUpdating = False
Set mainWorkBook = ActiveWorkbook
Sheets("Sheet1").Activate 'Puts all the picture filenames on "Sheet1" of the open workbook; change to the sheet name to suit
'NOTE: Be sure to change 'Sheet1' in any line of code below if you change it here.
'Enter the folderpath to wherever your pictures are coming from
Folderpath = InputBox("Enter the complete folder path to your files" & Chr(13) & " in this format: 'C:\Users\yourfoldername'")
Set fso = CreateObject("Scripting.FileSystemObject")
NoOfFiles = fso.GetFolder(Folderpath).Files.Count
Set listfiles = fso.GetFolder(Folderpath).Files
'Creates a list of complete path and filenames of all pictures in the directory you entered
rw = 1
For Each fls In listfiles
With Sheets("Sheet1")
.Range("A" & rw).Value = fls
rw = rw + 1
.Range("I" & rw - 1).Copy
.Range("I" & rw).PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, SkipBlanks:=False, Transpose:=False 'copies the formula in I1
End With
Next fls
Sheets("Sheet1").Range("I" & rw + 1).Select
'Now we need to open each Excel workbook, insert the photo, save and close... and repeat for each workbook in the directory.
LR = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row
myPath = "C:\completePath and Filename\" 'Enter the path to your Excel workbooks that are to receive the pictures
MyName = Dir(myPath, vbDirectory) 'Retrieve the first entry.
Do While MyName <> "" ' Start the loop.
' Ignore the current directory and the encompassing directory.
If MyName <> "." And MyName <> ".." Then
' Use bitwise comparison to make sure MyName is not a directory
If (GetAttr(myPath & MyName) And vbDirectory) <> vbDirectory Then
'Find .jpg and .xlsm with same name
For rw = 1 To LR
Workbooks("TEST2").Sheets("Sheet1").Range("L1").Value = MyName
nm1 = Workbooks("TEST2").Sheets("Sheet1").Range("N1").Value 'xlsm name
Workbooks("TEST2").Sheets("Sheet1").Range("O1").Value = Workbooks("TEST2").Sheets("Sheet1").Range("I" & rw).Value
nm2 = Workbooks("TEST2").Sheets("Sheet1").Range("P1").Value 'jpg name
If nm1 = nm2 Then
Workbooks.Open myPath & MyName
Call insert1(Workbooks("TEST2").Sheets("Sheet1").Range("A" & rw).Value, rw)
ActiveWorkbook.Close True
End If
Next rw
End If
End If
MyName = Dir ' Get next entry.
Loop
Workbooks("TEST2").Activate
Application.ScreenUpdating = True
MsgBox "Pictures Copied to Files"
End Sub
Function insert1(PicPath, counter1)
With ActiveSheet.Pictures.Insert(PicPath)
With .ShapeRange
.LockAspectRatio = msoTrue
'.Width = 50 'Adjust to change the WIDTH of your pictures_Commented out to maintain aspect ratio of pictures
.Height = 300 'Adjust to change the HEIGHT of your pictures
End With
.Left = ActiveSheet.Range("A1").Left
.Top = ActiveSheet.Range("A1").Top
.Placement = 1
.PrintObject = True
End With
End Function
