Inserting Multiple Images based on links??

[vivekmartin]

I'll make this simple. I have an Excel sheet with two columns (A & B) that contain paths to two different picture files saved on the local system. There are a total of 1,60,000 rows like this.
I need a macro to:
1. read the path in Column A and insert that picture in Column C
2. read the path in Column B and insert that picture in Column D
3. resize the cells to fit the pictures

Any help will be highly appreciated since I didn't find a solution on the boards yet and I'm in a bit of a fix here working against a deadline. Thank you.

[Fettertiger]

Hi Vivekmartin,

the following macro should (almost) do what you need. The only differences is that rather than resizing the cells, the macro will first adjust the row height to a "standard heigth" (adjustable), and then resize the pictures to fit into those cells. As the runtime for the huge number of pictures in your example can be rather long, I would suggest to test this first with a limited amount of pictures.

Option Explicit

Sub PastePictures()
    Dim i As Double
    Dim StandardRowHeight As Double
    Dim Lastrow As Double
    Dim MaxwidthC As Double
    Dim MaxwidthD As Double
    Dim Shp As Shape
    Dim PicturePath As String
    Dim PicCounter As Double


    'Adjust your setting Here
    StandardRowHeight = 50

    '________________________________________________________


    Application.ScreenUpdating = False
    'delete old pictures first
    For Each Shp In ActiveSheet.Shapes()
        If Left(Shp.Name, 5) = "PicA_" Or Left(Shp.Name, 5) = "PicB_" Then
            Shp.Delete
        End If
    Next Shp

    Lastrow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
    For i = 2 To Lastrow
        ActiveSheet.Rows(i).EntireRow.RowHeight = StandardRowHeight
        'column A
        PicturePath = ActiveSheet.Cells(i, 1).Value
        If PicturePath <> Empty Then
            'Paste to column C
            Cells(i, 3).Select
            ActiveSheet.Pictures.Insert(PicturePath).Select
            With Selection
                .Name = "PicA_" & i
                'Fix Picture Size
                .ShapeRange.LockAspectRatio = msoTrue
                .ShapeRange.Height = 0.9 * StandardRowHeight
                If .ShapeRange.Width > MaxwidthC Then MaxwidthC = .ShapeRange.Width
                PicCounter = PicCounter + 1
            End With
        End If
        
        'column B
        PicturePath = ActiveSheet.Cells(i, 2).Value
        If PicturePath <> Empty Then
            'Paste to column D
            Cells(i, 4).Select
            ActiveSheet.Pictures.Insert(PicturePath).Select
            With Selection
                .Name = "PicB_" & i
                'Fix Picture Size
                .ShapeRange.LockAspectRatio = msoTrue
                .ShapeRange.Height = 0.9 * StandardRowHeight
                If .ShapeRange.Width > MaxwidthD Then MaxwidthD = .ShapeRange.Width
                PicCounter = PicCounter + 1
            End With
        End If
    Next i
    'Adjust column width to the biggest picture
    ActiveSheet.Columns(3).EntireColumn.ColumnWidth = MaxwidthC / 5.35
    ActiveSheet.Columns(4).EntireColumn.ColumnWidth = MaxwidthD / 5.35
    Application.ScreenUpdating = True
    MsgBox PicCounter & " Pictures inserted succesfully!"
End Sub

For your reference I have attached my sample workbook.

Let me know if that is what you needed.

Theo