This code loops. Not sure if it is exacttly what you need. You may have tto
modify the code.

Sub GetPhoto()
Dim myPict As Picture
Dim myPictName As String
Dim rng As Range


Set rng = ActiveCell
myPictName = rng

For Each MyCell In ActiveSheet.Range("AA1:AA50")

If IsEmpty(MyCell) Then Exit Sub



MyCell.Select

Set myPict = ActiveSheet.Pictures.Insert(Filename:=myPictName)


myPict.Top = MyCell.Top
myPict.Left = MyCell.Left
myPict.Width = MyCell.Width
myPict.Height = MyCell.Height
myPict.Name = "Pict_" & MyCell.Address(0, 0)


Next MyCell

End Sub

"Akader" wrote:

Dear all
I have below code to insert photo automatically to each line,

I need your help to add looping to the code to run same code each line till
the empty line.

Many thanks

Abdul kader

== her the code ==

Sub GetPhoto()
Dim myPict As Picture
Dim myPictName As String
Dim rng As Range


Set rng = ActiveCell
myPictName = rng
With ActiveSheet
With .Range("AA1:AA50")

If IsEmpty(ActiveCell) Then Exit Sub
On Error Resume Next
If IsEmpty(ActiveCell.Offset(-1, 0)) Then Set TopCell = ActiveCell Else
Set TopCell = ActiveCell.End(xlUp)
If IsEmpty(ActiveCell.Offset(1, 0)) Then Set BottomCell = ActiveCell
Else Set BottomCell = ActiveCell.End(xlDown)
Range(TopCell, BottomCell).Select


Set myPict = .Parent.Pictures.Insert(Filename:=myPictName)
rng.Select

myPict.Top = rng.Top
myPict.Left = rng.Left
myPict.Width = rng.Width
myPict.Height = rng.Height
myPict.Name = "Pict_" & .Cells(1).Address(0, 0)


End With
End With
End Sub



== end of the code ==