Sub InsImg() ActiveSheet.Pictures.Delete Application.ScreenUpdating = False mPath = ActiveWorkbook.Path 'cartella con foto considera per default quella dove è il file If Range("A1") = "" Then Exit Sub tipo = Range("A1") mFront = tipo & "_front.jpg" mBack = tipo & "_back.jpg" mFoto = mFront Set Rng = Range("B1") For j = 1 To 2 If Dir(mPath & "\" & mFoto) <> "" Then Rng.Select With ActiveSheet.Pictures.Insert(mPath & "\" & mFoto) .ShapeRange.LockAspectRatio = msoFalse mTop = ActiveCell.Top mLeft = ActiveCell.Left mHeight = Range(ActiveCell.Address & ":" & ActiveCell.Offset(6).Address).Height mWidth = Range(ActiveCell.Address & ":" & ActiveCell.Offset(, 2).Address).Width .Top = mTop .Left = mLeft .Width = mWidth .Height = mHeight End With Else If j = 1 Then Range("C1") = "Foto inesistente" Else Range("E1") = "Foto inesistente" End If End If Set Rng = Range("E1") mFoto = mBack Next j Application.ScreenUpdating = True Cancel = True End Sub
alesc83, 07/05/2020 18:25:... Il codice di dodo47 .......... se non fosse che ogni volta devo eseguire la macro.....
dodo47:Se non vuoi ogni volta cliccare su un pulsante, potresti inserire il codice nell'evento change del foglio mirato alla cella A1.
Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, Range("A1")) Is Nothing Then Application.EnableEvents = False ActiveSheet.Pictures.Delete Application.ScreenUpdating = False ....... ....... ....... Next j Application.ScreenUpdating = True Application.EnableEvents = True End If End Sub
Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, Range("A1")) Is Nothing Then Application.EnableEvents = False ActiveSheet.Pictures.Delete Application.ScreenUpdating = False mPath = ActiveWorkbook.Path 'cartella con foto considera per default quella dove è il file If Range("A1") = "" Then Exit Sub tipo = Range("A1") mFront = tipo & "_front.jpg" mBack = tipo & "_back.jpg" mFoto = mFront Set Rng = Range("B1") For j = 1 To 2 If Dir(mPath & "\" & mFoto) = "" Then mFoto = "Manca.jpg" End If If Dir(mPath & "\" & mFoto) <> "" Then Rng.Select With ActiveSheet.Pictures.Insert(mPath & "\" & mFoto) .ShapeRange.LockAspectRatio = msoFalse mTop = ActiveCell.Top mLeft = ActiveCell.Left mHeight = Range(ActiveCell.Address & ":" & ActiveCell.Offset(6).Address).Height mWidth = Range(ActiveCell.Address & ":" & ActiveCell.Offset(, 2).Address).Width .Top = mTop .Left = mLeft .Width = mWidth .Height = mHeight End With End If Set Rng = Range("E1") mFoto = mBack Next j Application.ScreenUpdating = True Application.EnableEvents = True End If End Sub