Inserting picture into cell via VBA

[Joek88]

Hi all!

So the code below works very well on my workstation. The intention of the code is to grab a picture from another sheet and insert it into a specified merged cell when criteria is met in cells G8 and O8. My goal was to fit the picture into the cell disregarding any aspect ratio or scaling. I don't care if it's stretched or skewed, I just want the picture to fit into the merged cell. When I send this file over to a friend on a different computer, the excel sheet apparently does not work the same. It does place the picture in the same desired merged cell, however, it does not stretch it and fit it perfectly like on my workstation. Why is this happening? I am running windows 10 and he is running windows 11, I doubt this should make a difference. Please, if you have any insight or my code needs fixed please let me know.

Private Sub Worksheet_Change(ByVal target As Range)
    ' Code for the first Worksheet_Change event
    sub1 target
    sub2 target
    sub3 target
    sub4 target

    ' Code for the second Worksheet_Change event
    Dim r As Long
    Dim curVal As Long
    Dim prevRng As Range
    Dim curRng As Range
    
    Dim sourceWS As Worksheet
    Dim targetWS As Worksheet
    Dim sourcePic As Shape
    Dim targetRange As Range
    Dim copiedPic As Shape
    Dim conditionCellG8 As Range
    Dim conditionCellO8 As Range

    ' Define the source worksheet (where the picture is located)
    Set sourceWS = ThisWorkbook.Sheets("DATA VALIDATION")

    ' Define the target worksheet (where you want to insert the picture)
    Set targetWS = ThisWorkbook.Sheets("Cable-Conduit-Fiber Schedul")

    ' Define the target range where you want to insert the picture
    Set targetRange = targetWS.Range("V14:AH21")

    ' Define the condition cell G8
    Set conditionCellG8 = Me.Range("G8")

    ' Define the condition cell O8
    Set conditionCellO8 = Me.Range("O8")

    ' Check if either G8 or O8 has changed
    If Not Intersect(target, conditionCellG8) Is Nothing Or Not Intersect(target, conditionCellO8) Is Nothing Then
        ' Check if cell G8 has a value of "TOP" and cell O8 has a value of "FUSED"
        If conditionCellG8.Value = "TOP" And conditionCellO8.Value = "FUSED" Then
            ' Identify the picture shape in the source worksheet
            Set sourcePic = sourceWS.Shapes("Picture 3")

            ' Copy the picture shape to the target worksheet
            sourcePic.Copy

            ' Paste the copied picture into the target range
            targetRange.PasteSpecial

            ' Set the copied picture shape as a new shape object
            Set copiedPic = targetWS.Shapes(targetWS.Shapes.Count)

            ' Stretch the copied picture to fit the target range without maintaining aspect ratio
            With copiedPic
                .Top = targetRange.Top
                .Left = targetRange.Left
                .Width = targetRange.Width
                .Height = targetRange.Height
            End With

            ' Clear clipboard
            Application.CutCopyMode = False
        End If
    End If

 

[Domenic]

Try setting the LockAspectRatio property to False....

            ' Stretch the copied picture to fit the target range without maintaining aspect ratio
            With copiedPic
                .LockAspectRatio = msoFalse
                .Top = targetRange.Top
                .Left = targetRange.Left
                .Width = targetRange.Width
                .Height = targetRange.Height
            End With

Hope this helps!

 

[Joek88]

Hmm, this did not work. I don't understand why the picture is not filling out the cell. It places in the cell but does not fully stretch it to fit.