Risolto:
codice:Sub CaricaFoto() Dim i As Variant On Error GoTo PictureNotAvailable Application.DisplayAlerts = False For e = 4 To Sheets("Aggiorna").Range("C1").Value foglio = Sheets("Aggiorna").Range("B" & e).Value origine = Sheets("Aggiorna").Range("C" & e).Value colonna = Sheets("Aggiorna").Range("D" & e).Value Sheets(foglio).Select ActiveSheet.Range("a1").Select ' Ciclo tutte le foto del foglio e le cancello For Each i In Sheets(foglio).Shapes If Left(i.Name, 7) = "Picture" Then i.Delete Next i ' Ciclo tutte le celle e cancello gli NA For Each i In Sheets(foglio).Range(origine) ActiveSheet.Cells(i.Row, colonna).Value = "" Next i ' Carico la foto e la ridimensiono con la grandezza della cella For Each i In Sheets(foglio).Range(origine) 'Se il modello ha uno spazio lo cambio con un underscore nomefile = Replace(i.Value, " ", "_") 'Seleziono la cella ActiveSheet.Cells(i.Row, colonna).Select 'Decido dove mettere la foto var_Width = Sheets(foglio).Columns(colonna).ColumnWidth var_Height = Sheets(foglio).Cells(i.Row, colonna).Height 'Carico la foto ActiveSheet.Pictures.Insert("\\xxxxx\xxxx\xxxx\xxx\xxx\xxx\0" & _ Mid(i.Value, 2, 2) & "\AUTO_600_600\" & nomefile & ".JPG").Select 'Ridimensione la foto var_Width = Sheets(foglio).Columns(colonna).ColumnWidth var_Height = Sheets(foglio).Cells(i.Row, colonna).Height Selection.Width = var_Width Selection.Height = var_Height 'Aggiungo Hyperlink alla foto Sheets(foglio).Hyperlinks.Add Anchor:=Selection.ShapeRange.Item(1), Address:="\\luxedge1\LuxPicsCache\parts\wip\default\warn\0" & _ Mid(i.Value, 2, 2) & "\AUTO_600_600\" & nomefile & ".JPG" Next i 'Posiziono il cursore in testa al foglio ActiveSheet.Range("a1").Select Next e 'Torno nel foglio principale e avviso che il caricamento è terminato Sheets("Aggiorna").Select MsgBox ("Caricamento foto terminato!"), vbInformation Exit Sub PictureNotAvailable: ActiveSheet.Cells(i.Row, colonna).Value = "N.A." Resume Next End Sub

Rispondi quotando