Una volta selezionati i vari francobolli clicco sul bottone "aggiorna IMMAGINI" e la sub sottonotata dovrebbe cambiare le immagini che si trovano nelle celle E3:L3
Prima che riesca a mandare il file(mi so incartato!!!) si può vedere perchè questa dannata sub non riesce più a fungere(fino a due gg fa funzionava perfettamente) devo dire che il file originario era francese ed era composto da 4 fogli che man mano ho cambiato e ridotto a 2 e ripeto funzionava ma ora a causa delle notevoli modifiche non riesco più a recuperare la macro si blocca a questa riga:
.Rows(3).Cells.Clear ' qui cancella il contenuto della riga 3
ovvero cancella le immagini presistenti ma non le cambia con quelle scelte nelle celle E3:L3
Ora lo so che sarebbe tutto più semplice con un immagine ma adesso non riesco bo!!
- Codice: Seleziona tutto
Sub Importaimmagini()
Dim sh As Shape, dossier$, Img$, i%, c As Range
Application.ScreenUpdating = False
With ActiveSheet
If .[A2] = "" Then
MsgBox "Prima metti il percorso del file in A2 !", vbExclamation
Exit Sub
End If
If Right(.[A2], 1) = "\" Then
.[A2] = Left(.[A2], Len(.[A2]) - 1)
End If
dossier = .[A2]
If Dir(dossier, vbDirectory) = "" Then
MsgBox " la Cartella non esiste !", vbExclamation
Exit Sub
End If
For Each sh In .Shapes
If sh.Type = msoLinkedPicture Then sh.Delete
Next
.Rows(3).Cells.Clear ' qui cancella il contenuto della riga 3
dossier = dossier & "\"
For i = 5 To .Range("IV4").End(xlToLeft).Column
If .Cells(4, i) <> "" Then
Img = Dir(dossier & .Cells(4, i) & "*")
If Img <> "" Then
Set c = .Cells(3, i)
With c
.Value = Imgdossier
.ColumnWidth = 15 'Larghezza delle colonne
.RowHeight = 82 'Altezza delle righe
.Font.ColorIndex = 2
.Font.Size = 6
End With
Set sh = .Shapes.AddPicture(dossier & Img, True, True, c.Left + 5, c.Top + 1, 76, 76)
'
sh.Name = .Cells(4, i)
End If
End If
Next
End With
End Sub