Looping to insert photo

[Akader]

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 ==

 

[Joel]

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

 

[Dave Peterson]

I'm not sure what you're doing, but maybe something like:

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

With ActiveSheet
For Each rng In .Range("AA1:AA50").Cells
If IsEmpty(rng.Value) Then
Exit For
End If

myPictName = rng.Value
testStr = ""
On Error Resume Next
testStr = Dir(myPictName)
On Error GoTo 0

If testStr = "" Then
MsgBox myPictName & " wasn't found!"
Else
Set myPict = .Parent.Pictures.Insert(Filename:=myPictName)

With rng.Offset(0, -1) 'column Z

myPict.Top = .Top
myPict.Left = .Left
myPict.Width = .Width
myPict.Height = .Height
myPict.Name = "Pict_" & .Address(0, 0)
End With
End If
Next rng
End With
End Sub

 

[Akader]

thank you very much Joel & Dave
for you help, the code are not working as I like.

Please download my excel file example for what I need, I hope i will be
clear to you.

http://www.nouran.com/GetPhoto-temp.zip

----
open the attacfhed file,

to run the code / just click on any colume from B4 to B7 then click on (Get
photo) , the result will show in the same colume , I need to run the code on
all coulme with photo path all together after I click on Get photo.

 

[Dave Peterson]

I don't open other workbooks.

Maybe Joel will--or someone else will.

Or you can post a description in plain text.

 

[Akader]

thank Dave
why i need you to open my file, just to see the real example.
because maybe i not able to description my request very well.

once again thanks

 

[Dave Peterson]

Maybe someone else will volunteer.

Good luck.

thank Dave
why i need you to open my file, just to see the real example.
because maybe i not able to description my request very well.

once again thanks

 

[Akader]

any how many thanks dave for your support

Maybe someone else will volunteer.

Good luck.

 

[Akader]

thank you guys
I find solution to my problem , here is the code just for your info.


==== start ===

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

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



For Each cl In Selection.Cells
cl.Activate

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

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


Next cl

End With
End With
End Sub

==== end ===