Select image and post into merged cell

[captzero]

Hi All,
I'm struggling to place an image in a merged cell in multiple worksheets.
My command button needs to open the folder, allow the user to select an image file, and resize it and centre it to fit in a merged cell in 4 spreadsheets.
The merged cells are the same size and in the same location in the 4 spreadsheets (G8:H16).

The code I have nearly gets it right but I can't resize and centre it in the merged cell as I'd like.

Thank you in advance.

'Inserts job image into Pricing, Quote, Invoice and Receipt spreadsheets.
Private Sub CommandButton1_Click()
Dim fNameAndPath As Variant
Dim img As Picture
Dim SheetsNames(), i As Long

SheetsNames = Array("Project Pricing Calculator", "Customer Job Quote", "Customer Invoice", "Customer Receipt")
fNameAndPath = Application.GetOpenFilename(Title:="Locate the Job Image File To Be Imported")

If fNameAndPath = False Then Exit Sub
 
    For i = LBound(SheetsNames) To UBound(SheetsNames)
        Set img = ActiveWorkbook.Sheets(SheetsNames(i)).Pictures.Insert(fNameAndPath)
        With img
           'Resize Picture to fit in the cell range....
           .ShapeRange.LockAspectRatio = msoTrue              ' lock aspect ratio checkbox not selected
           '.Left = ActiveSheet.Range("G8:H16").Left
           '.Top = ActiveSheet.Range("G8:H16").Top
           .Placement = 1
           .PrintObject = True
        End With
    Next i
    Worksheets("Project Pricing Calculator").Activate
End Sub

 

[DanteAmor]

Try this:

Private Sub CommandButton1_Click()
  Dim fNameAndPath As Variant
  Dim img As Picture
  Dim SheetsNames(), i As Long
  Dim rng As Range
  Dim sh As Worksheet
  
  SheetsNames = Array("Project Pricing Calculator", "Customer Job Quote", _
                      "Customer Invoice", "Customer Receipt")
  fNameAndPath = Application.GetOpenFilename(Title:="Locate the Job Image File To Be Imported")
  
  If fNameAndPath = False Then Exit Sub
  For i = LBound(SheetsNames) To UBound(SheetsNames)
    Set sh = Sheets(SheetsNames(i))
    'Delete the old image to put the new image
    On Error Resume Next: sh.Pictures("NewPicture").Delete: On Error GoTo 0
    Set rng = sh.Range("G8:H16")
    Set img = sh.Pictures.Insert(fNameAndPath)
    With img
      .Name = "NewPicture"
      'Resize Picture to fit in the cell range....
      .ShapeRange.LockAspectRatio = msoFalse    ' lock aspect ratio checkbox not selected
      .Left = rng.Left
      .Top = rng.Top
      .Width = rng.Width
      .Height = rng.Height
      .Placement = 1
      .PrintObject = True
    End With
  Next i
  Sheets(SheetsNames(0)).Activate
End Sub

 

[captzero]

Thnk you DanteAmor. Works great and I learned a little more about VBA today.