Edit to currently working Macro

[ipbr21054]

Afternoon,
I have the code in use shown below.

Can we edit this code so upon the Macro button press it would then put the image into the cell as opposed to me manually doing it each time.
Here is some info that might help you.
Part number is always in Column & currently A3 then done the list.
Image will be inserted into the cell next to its part number so Column B
Images are always stored here at this path C:\Users\Ian\Desktop\SKYPE\LOCK PICK ME\

I am looking to save time with this so this is how it will work.
Part number in cell A100 is 12345
I would select celol B100 & press the macro
The macro would then use the path supplied to then insert photo 12345.jpg into the cell selected of which is B100

I did try to record a macro to look at the code but run into errors and got lost trying to fix them.

Sub CompressPicture()Dim fName As String
Dim pic As Picture
Dim r As Range


ChDir "C:\Users\Ian\Desktop\SKYPE\LOCK PICK ME"
fName = Application.GetOpenFilename( _
        FileFilter:="Images (*.jpg;*.gif;*.png),*.jpg;*.gif;*.png", _
        Title:="Please select an image...")
If fName = "False" Then Exit Sub


Set r = ActiveCell
Set pic = Worksheets("LPM").Pictures.Insert(fName)


With pic
    .ShapeRange.LockAspectRatio = msoFalse
    .Left = r.Left + 5
    .Top = r.Top + 5
    .Width = r.Width - 10
    .Height = r.Height - 10
    .Select
End With


If TypeName(Selection) = "Picture" Then
    Application.SendKeys "%a~"
    Application.CommandBars.ExecuteMso "PicturesCompress"
End If
End Sub

Have a nice day.

 

[ipbr21054]

Hi,
Just an update.

I am now using the code shown below & works fine like it require it.

I have one issue that i cant figure.

If i type a file number into a cell but the photo isnt present in the folder then i see the msgbox "Photo Doesn't exist!" which it should do.
I click OK but i then see a run time error 1004 "Unable to get the insert property of the picture class"
Can you advise what ive missed please

Private Sub Worksheet_Change(ByVal Target As Range)Dim shp As Shape
If Intersect(Target, [A:A]) Is Nothing Then Exit Sub
If Target.Row Mod 20 = 0 Then Exit Sub
On Error GoTo son


For Each shp In ActiveSheet.Shapes
If shp.Type = msoPicture And shp.TopLeftCell.Address = Target.Offset(0, 4).Address Then shp.Delete
Next


If Target.Value <> "" And Dir("C:\Users\Ian\Desktop\SKYPE\LOCK PICK ME\" & "\" & Target.Value & ".jpg") = "" Then
        'picture not there!
        MsgBox Target.Value & " Photo Doesn't exist!"
End If


ActiveSheet.Pictures.Insert("C:\Users\Ian\Desktop\SKYPE\LOCK PICK ME\" & "\" & Target.Value & ".jpg").Select
Selection.Top = Target.Offset(0, 1).Top + 5
Selection.Left = Target.Offset(0, 1).Left + 5


With Selection.ShapeRange
.LockAspectRatio = msoFalse
.Height = Target.Offset(0, 1).Height - 10
.Width = Target.Offset(0, 1).Width - 10
End With
Target.Offset(1, 0).Select
son:


End Sub

 

[JackDanIce]

Untested, but see line in red, I'm not sure why it wasn't going to son when error of photo not found was generated

Private Sub Worksheet_Change(ByVal Target As Range)

    Dim shp As Shape
    Dim msg As String
    
    With Target
        If .Column <> 1 Or .Row Mod 20 = 0 Then Exit Sub
    End With
    
    On Error GoTo son
        
    For Each shp In achtivesheet.Shapes
        With shp
            If .Type = msoPicture And .TopLeftCell.Address = Target.Offset(, 4).Address Then .Delete
        End With
    Next shp
    
    msg = Replace("C:\Users\Ian\Desktop\SKYPE\LOCK PICK ME\\@TV.jpg", "@TV", Target.Value)
    If Len(Target.Value) And Len(Dir(msg)) = 0 Then
        MsgBox Target.Value & " photo doesn't exist, macro stopping", vbExclamation, Replace("Photo @TV not found", "@TV", Target.Value)
        Exit Sub
    End If

    ActiveSheet.Pictures.Insert(msg).Select
    With Selection
        .Top = Target.Offset(, 1).Top + 5
        .Left = Target.Offset(, 1).Left + 5
        With .ShapeRange
            .LockAspectRatio = msoFalse
            .Height = Target.Offset(, 1).Height - 10
            .Width = Target.Offset(, 1).Width - 10
        End With
    End With
    Target.Offset(1).Select

son:
End Sub

 

[ipbr21054]

Many Thanks it worked fine.

Have a nice day

 

[JackDanIce]

You're welcome, glad it's resolved, you too.