Moderatori: Anthony47, Flash30005
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("A" & Rows.Count).End(xlUp).Row ' Ultima riga con dati
If Not Intersect(Target, Range("A2:A" & UR)) Is Nothing Then
mPath = "D:\Temp" ' <<===== 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
Ciao Antonella,
è venerdì ed ho tempo ... ecco un FILE di ESEMPIO.
Dovrai cambiare il percorso ... leggi i commenti che ho scritto nel codice.
Nel file ho già inserito delle immagini, posizionati sulla cella "A2" e premi "Canc" oltre che il nome verrà cancellata anche l'immagine presente in "B2", procedi con le altre immagini cancellando i nome, sempre in colonna "A".
Inserisci un nome di un fiore in "A2" e ...
Sub Worksheet_Change(ByVal Target As Range)
Dim mPath As String, mFoto As String, myArea As String, Cella As Range
'
myArea = "A2:A150" '<< Le celle dove potrai scrivere nomi immagini
'
If Application.Intersect(Range(myArea), Target) Is Nothing Then Exit Sub
'
For Each Cella In Target
On Error Resume Next
ActiveSheet.Shapes("FOTO_DA_" & Cella.Address(0, 0)).Delete
On Error GoTo 0
If Cella.Value <> "" Then
mPath = "C:\TempFoto" ' <<===== QUI scrivi il percorso ove hai le tue foto
mFoto = Cella.Value
If Dir(mPath & "\" & mFoto & ".jpg") <> "" Then ' Si controlla se la foto esiste
Application.ScreenUpdating = False
With ActiveSheet.Pictures.Insert(mPath & "\" & mFoto & ".jpg")
.Top = Cella.Offset(0, 1).Top + 5
.Left = Cella.Offset(0, 1).Left + 5
.Height = Cella.Offset(0, 1).Height - 10
.Width = Cella.Offset(0, 1).Width - 10
.Name = "FOTO_DA_" & Cella.Address(0, 0)
End With
Application.ScreenUpdating = True
Else
MsgBox ("Immagine non trovata: " & Cella.Value) ' <<====== QUI scrivi il messaggio che vuoi sia inviato
End If
End If
Next Cella
End Sub
Sub Worksheet_Change(ByVal Target As Range)
Dim mPath As String, mFoto As String, myArea As String, Cella As Range
'
myArea = "A2:A150" '<< Le celle dove potrai scrivere nomi immagini
'
If Application.Intersect(Range(myArea), Target) Is Nothing Then Exit Sub
'
For Each Cella In Target
' On Error Resume Next
ActiveSheet.Shapes("FOTO_DA_" & Cella.Address(0, 0)).Delete
' On Error GoTo 0
If Cella.Value <> "" Then
mPath = "C:\TempFoto" ' <<===== QUI scrivi il percorso ove hai le tue foto
mFoto = Cella.Value
If Dir(mPath & "\" & mFoto & ".jpg") <> "" Then ' Si controlla se la foto esiste
Application.ScreenUpdating = False
With ActiveSheet.Pictures.Insert(mPath & "\" & mFoto & ".jpg")
.Top = Cella.Offset(0, 1).Top + 5
.Left = Cella.Offset(0, 1).Left + 5
' .Height = Cella.Offset(0, 1).Height - 10
' .Width = Cella.Offset(0, 1).Width - 10
.Name = "FOTO_DA_" & Cella.Address(0, 0)
End With
On Error Resume Next
With ActiveSheet.Shapes("FOTO_DA_" & Cella.Address(0, 0))
.LockAspectRatio = True
.Height = Cella.Height - 10
If .Width > Cella.Offset(0, 1).Width Then .Width = Cella.Offset(0, 1).Width - 10 '***
End With
On Error GoTo 0
Application.ScreenUpdating = True
Else
MsgBox ("Immagine non trovata: " & Cella.Value) ' <<====== QUI scrivi il messaggio che vuoi sia inviato
End If
End If
Next Cella
End Sub
For Each Cella In Target
On Error Resume Next
ActiveSheet.Shapes("FOTO_DA_" & Cella.Address(0, 0)).Delete
On Error GoTo 0
For Each Cella In Application.Intersect(Range(myArea), Target)
myArea = "A2:A" & EndRow '<< Le celle dove potrai scrivere nomi immagini
Torna a Applicazioni Office Windows
[EXCEL] controllo corrispondenza tra valori con un vincolo Autore: sbs |
Forum: Applicazioni Office Windows Risposte: 9 |
Importare immagini a seconda del testo in una cella Autore: Paolo67met |
Forum: Applicazioni Office Windows Risposte: 4 |
Come impostare il formato data predefinito in excel? Autore: wallace&gromit |
Forum: Applicazioni Office Windows Risposte: 5 |
Visitano il forum: Nessuno e 13 ospiti