Picture macro/vba

MLoveless

New Member
Joined
Mar 6, 2015
Messages
3
Hello,

I would like to auto populate photos of the products based on the value in a column.

For example
I would copy and paste a list of style numbers in Column A (could be hundred of lines)
Click a button and it populate the images in Column B based on the values in Column A

Ideally i would like the photos to be stored in a shared drive such as Microsoft oneDrive or Google drive library if possible.

I have looked for threads online but it seems like all of them are based on a limited number of lookup.

Can you please help?


1595277440502.png
 

Excel Facts

Shade all formula cells
To shade all formula cells: Home, Find & Select, Formulas to select all formulas. Then apply a light fill color.
.
VBA Code:
Option Explicit

Sub AddOlEObject()

    Dim mainWorkBook As Workbook
    Dim Folderpath, fStr, myPath, Filename As String
    Dim fso, NoOfFiles, listfiles, fls, strCompFilePath
    Dim counter
    
    Set mainWorkBook = ActiveWorkbook
    Sheets("Sheet1").Activate
    Folderpath = "C:\Users\gagli\Desktop\Impeachment"   '<-- Change path to your images here
    Set fso = CreateObject("Scripting.FileSystemObject")
    NoOfFiles = fso.GetFolder(Folderpath).Files.Count
    Set listfiles = fso.GetFolder(Folderpath).Files
    
    Application.ScreenUpdating = False
    
    For Each fls In listfiles
       strCompFilePath = Folderpath & "\" & Trim(fls.Name)
        If strCompFilePath <> "" Then
        
            '// include image extensions here \\
            
            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
                 Filename = fls.Name
                    If InStr(Filename, ".") > 0 Then
                       Filename = Left(Filename, InStr(Filename, ".") - 1)
                    End If
                  Sheets("Sheet1").Range("A" & counter).Value = Filename
                  Sheets("Sheet1").Range("B" & counter).ColumnWidth = 25
                Sheets("Sheet1").Range("B" & counter).RowHeight = 100
                Sheets("Sheet1").Range("B" & counter).Activate
                Call insert(strCompFilePath, counter)
                Sheets("Sheet1").Activate
            End If
        End If
    Next
    
    Application.ScreenUpdating = True
'mainWorkBook.Save


End Sub

Function insert(PicPath, counter)
'MsgBox PicPath
    With ActiveSheet.Pictures.insert(PicPath)
    
    '// change image sizes here \\
        
        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


Sub DeleteShapes_ActiveSheet()
  Dim shp As Shape
  For Each shp In ActiveSheet.Shapes
    If shp.Type = msoPicture Then shp.Delete
  Next shp
End Sub

Sub delext()
Filename = ActiveWorkbook.Name
If InStr(Filename, ".") > 0 Then
   Filename = Left(Filename, InStr(Filename, ".") - 1)
End If

End Sub

Download workbook : Display One Pic Per Cell Strip Ext From Pic Name.xlsm
 
Upvote 0

Forum statistics

Threads
1,213,536
Messages
6,114,215
Members
448,554
Latest member
Gleisner2

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top