Preuzeo sam i doterao rutinu koja umece sliku u celiju. Zatim se ta rutina poziva u petji za sve popunjene celije iz kolone A
Code:
Sub Test()
' Za sve popunjene celije u koloni A
' Dodaje sliku kao hiperlink u koloni B
Dim cl As Range
Dim sh As Worksheet
Dim rw As Long, rwstart As Integer, rwend As Long
Dim path As String
Set sh = ActiveSheet ' Uzima se aktivni list
path = "F:\My Documents\My Pictures\" ' Ovde zadati folder
rwstart = 1 ' Ovde zadati pocetni red
rwend = sh.Cells(16555, 1).End(xlUp).Row
sh.Columns(2).ColumnWidth = 13.57 ' Podesava se sirina kolone na 100 piksela
For rw = rwstart To rwend
Set cl = ActiveSheet.Cells(rw, 2)
cl.Rows(1).RowHeight = 75 ' Podesava se visina reda na 100 piksela
InsertPictureInRange path & cl.Offset(ColumnOffset:=-1).Text & ".jpg", cl
Next
End Sub
Sub InsertPictureInRange(PictureFileName As String, TargetCells As Range)
' Umece sliku i prilagodjava je velicini odredišne celije
' zatim dodaje Hiperlink
' Prepravljeno sa exceltip.com
Dim p As Object, s As Shape
Dim t As Double, l As Double, w As Double, h As Double
If TypeName(ActiveSheet) <> "Worksheet" Then Exit Sub
If Dir(PictureFileName) = "" Then Exit Sub
' Umetanje slike
Set p = ActiveSheet.Pictures.Insert(PictureFileName)
' Odredjivanje pozicije
With TargetCells
t = .Top
l = .Left
w = .Offset(0, .Columns.Count).Left - .Left
h = .Offset(.Rows.Count, 0).Top - .Top
End With
' Pozicioniranje slike
With p
.Top = t
.Left = l
.Width = w
.Height = h
End With
' Kao argument Anchor za hiperlink treba da se prenese shape
TargetCells.Worksheet.Hyperlinks.Add Anchor:=p.ShapeRange(1), _
Address:=PictureFileName
Set p = Nothing
End Sub
Nije to loše Rembrante, samo što ne bi dodao još malo boje?