I
ian bartlett
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
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