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
Per copiare il codice opera in questo modo:
1. seleziona il foglio
2. tasto destro
3. visualizza codice
4. nella finestra di destra copia il codice
Dopo aver copiato scrivi/modifica/cancella un nome in una cella della colonna "A" e ...
Sub Worksheet_Change(ByVal Target As Range)
Sub Worksheet_Change(ByVal Target As Range)
Dim mPath As String, mFoto As String, myArea As String, Cella As Range
'
myArea = "A2:A4" '<< 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:\PROVA" ' <<===== 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 CancellaImm()
For Each oOgg In ActiveSheet.Shapes
oOgg.Delete
Next oOgg
End Sub
Sub Cancella()
UR = Range("A" & Rows.Count).End(xlUp).Row
For RR = 2 To UR
On Error Resume Next
ActiveSheet.Shapes("FOTO_DA_A" & RR).Delete
On Error GoTo 0
Next RR
End Sub
Sub PicDel()
Dim Sh
Colonna = 2 '<<La colonna da cancellare; 1=A, 2=B, ...
'
For Each Sh In ActiveSheet.Shapes
If Sh.Type = msoPicture Or Sh.Type = msoLinkedPicture Then
If Sh.TopLeftCell.Column = Colonna Then Sh.Delete
End If
Next Sh
End Sub
Torna a Applicazioni Office Windows
Inserire dati filtrati da 2 file ad un terzo file Autore: Ricky0185 |
Forum: Applicazioni Office Windows Risposte: 14 |
Inserire add.in nella barra di avvio veloce in excel 2003 Autore: Ricky0185 |
Forum: Applicazioni Office Windows Risposte: 4 |
Excel: problema con date se devo unirle a testi Autore: valle1975 |
Forum: Applicazioni Office Windows Risposte: 5 |
Visitano il forum: Nessuno e 46 ospiti