Ho trovato una macro di Anthony che funziona benissimo se applicata al foglio singolo, ma io dovrei estenderla a tutti i fogli restanti. Ho provato a copiarla in This worbook ma non funziona, come devo fare ?
Allego la macro.
- Codice: Seleziona tutto
Private Sub Worksheet_Change(ByVal Target As Range)
Dim UR As Long, R As Long, I As Long, mPath As String, mFoto As String
Dim oOgg As Shape, SH As Sheets
If Target.Columns.Count > 1 Or Target.Rows.Count > 1 Then
MsgBox "Operare solo su una cella"
Exit Sub
End If
If Target <> "" Then
UR = Range("E" & Rows.Count).End(xlUp).Row ' Ultima riga con dati
If Not Intersect(Target, Range("E3:E" & UR)) Is Nothing Then
mPath = "C:\Users\gianca\Documents\Storico uscite\immagini" ' <<===== QUI scrivi il percorso ove hai le tue foto
mFoto = Target
If Dir(mPath & "\" & mFoto & ".jpg") <> "" Then ' Si controlla se la foto esiste
Application.ScreenUpdating = False
For Each oOgg In ActiveSheet.Shapes
If oOgg.Top - 4.5 = Target.Top Then
oOgg.Delete ' Si cancella l'immagine esistente
Exit For
End If
Next oOgg
With ActiveSheet.Pictures.Insert(mPath & "\" & mFoto & ".jpg")
.Top = Target.Offset(0, 1).Top + 5
.Left = Target.Offset(0, 1).Left + 5
.Height = Target.Offset(0, 1).Height - 10
.Width = Target.Offset(0, 1).Width - 10
End With
Application.ScreenUpdating = True
Else
MsgBox "Immagine non trovata" ' <<====== QUI scrivi il messaggio che vuoi sia inviato
End If
Else
MsgBox "Scrivere un nome in una cella della colonna 'A'"
End If
Else
For Each oOgg In ActiveSheet.Shapes
If oOgg.Top - 4.5 = Target.Top Then
oOgg.Delete ' Si cancella l'immagine esistente
Exit For
End If
Next oOgg
End If
End Sub