Pictures in comments Sub MyPix modification ??
 

This was posted some time ago, I can't find the original post, I was
wondering if this could be modified as noted by astericks below ie. the
range affected
Thanks
Bart


Option Explicit
Sub Mypix()

Dim c As Object
Dim eMsg As String
Dim Pathe As String
Dim rngCell As Range
Dim rngSheet As Range
Dim curWks As Worksheet

'Handle errors
On Error Goto endo

'Speed
Application.ScreenUpdating = False

'Create reference
Set curWks = ActiveSheet

'Employ reference
With curWks
'Clear all old comments
.Columns("A").ClearComments ****I imagine you would add
..Columns("f").ClearComments
'Define range as Col A1 to last row Col A
Set rngSheet = .Range("A1:A" & Cells(Rows.Count, "A").End(xlUp).Row)
***change to ******a1:a32 and f1:f32
End With

'Drive (& optionally directory) must end with "\"
Pathe = "L:\"

'For each cell
For Each rngCell In rngSheet
'If blank
If Trim(rngCell.Value) = "" Then
'do nothing
ElseIf Dir(Pathe & rngCell.Value & ".jpg") = "" Then
'picture not there!
MsgBox rngCell.Value & " doesn't exist!"
Else
'put picture
rngCell.AddComment("").Shape.Fill.UserPicture (Pathe &
rngCell.Value & ".jpg")
End If
Next rngCell

'Set size for all pictures
For Each c In ActiveSheet.Comments
c.Shape.Width = 400
c.Shape.Height = 300
Next c

'Destroy reference\
Set c = Nothing
Set curWks = Nothing
Set rngCell = Nothing
Set rngSheet = Nothing

'Reset
Application.ScreenUpdating = True

'Normal exit
Exit Sub
'Errored out
endo:
'Destroy reference\
Set c = Nothing
Set curWks = Nothing
Set rngCell = Nothing
Set rngSheet = Nothing

'Reset
Application.ScreenUpdating = True

eMsg = MsgBox("Error number: " & Err.Number & " " & Err.Description,
vbCritical)
End Sub

Pictures in comments Sub MyPix modification ??
 

Maybe...

With curWks
'Clear all old comments
.Columns("A").ClearComments
.columns("F").clearcomments
Set rngSheet = .Range("A1:a32,f1:f32")
End With

ian bartlett wrote:

This was posted some time ago, I can't find the original post, I was
wondering if this could be modified as noted by astericks below ie. the
range affected
Thanks
Bart

Option Explicit
Sub Mypix()

Dim c As Object
Dim eMsg As String
Dim Pathe As String
Dim rngCell As Range
Dim rngSheet As Range
Dim curWks As Worksheet

'Handle errors
On Error Goto endo

'Speed
Application.ScreenUpdating = False

'Create reference
Set curWks = ActiveSheet

'Employ reference
With curWks
'Clear all old comments
.Columns("A").ClearComments ****I imagine you would add
.Columns("f").ClearComments
'Define range as Col A1 to last row Col A
Set rngSheet = .Range("A1:A" & Cells(Rows.Count, "A").End(xlUp).Row)
***change to ******a1:a32 and f1:f32
End With

'Drive (& optionally directory) must end with "\"
Pathe = "L:\"

'For each cell
For Each rngCell In rngSheet
'If blank
If Trim(rngCell.Value) = "" Then
'do nothing
ElseIf Dir(Pathe & rngCell.Value & ".jpg") = "" Then
'picture not there!
MsgBox rngCell.Value & " doesn't exist!"
Else
'put picture
rngCell.AddComment("").Shape.Fill.UserPicture (Pathe &
rngCell.Value & ".jpg")
End If
Next rngCell

'Set size for all pictures
For Each c In ActiveSheet.Comments
c.Shape.Width = 400
c.Shape.Height = 300
Next c

'Destroy reference\
Set c = Nothing
Set curWks = Nothing
Set rngCell = Nothing
Set rngSheet = Nothing

'Reset
Application.ScreenUpdating = True

'Normal exit
Exit Sub
'Errored out
endo:
'Destroy reference\
Set c = Nothing
Set curWks = Nothing
Set rngCell = Nothing
Set rngSheet = Nothing

'Reset
Application.ScreenUpdating = True

eMsg = MsgBox("Error number: " & Err.Number & " " & Err.Description,
vbCritical)
End Sub

--

Dave Peterson