How to add images to the cells in excel vba

Question

I want to add an image to Cell B1, and then put the same images to B15, B29, B43, ......B57 (which are increasing by 14) at once

I searched for the ways to do this, but couldn't find how to. Could someone please tell me how to do this?

Answer 1

Option 1 based on this solution

Option Explicit

Sub TiragePictures()
    Const PicPath = "c:\PPP\AAA.png" ' your own path to the image
    Dim ws As Worksheet, r As Long, cell As Range
    
    Set ws = ActiveSheet
    For r = 15 To 57 Step 14
        Set cell = ws.Cells(r, "B")
        With ws.Pictures.Insert(PicPath)
            With .ShapeRange
                .LockAspectRatio = msoTrue
                .Width = 70
                .Height = 50
            End With
            .Left = cell.Left
            .Top = cell.Top
            .Placement = 1
            .PrintObject = True
        End With
    Next
End Sub

Option2 with Shapes.AddPicture method

Sub TiragePictures2()
    Const PicPath = "c:\PPP\AAA.png" ' your own path to the image
    Dim ws As Worksheet, r As Long, cell As Range, sh As Shape
    
    Set ws = ActiveSheet
    For r = 15 To 57 Step 14
        Set cell = ws.Cells(r, "B")
        With ws.Shapes.AddPicture(Filename:=PicPath, LinkToFile:=False, _
                                  SaveWithDocument:=True, Left:=cell.Left, _
                                  Top:=cell.Top, Width:=-1, Height:=-1) '-1 retains the width/height of the existing file
            .LockAspectRatio = True 'before resizing, set the proportions to keep
            .Width = 70
            .Height = 50
        End With
    Next
End Sub