I'm trying to insert pics based on values that appear in a cell. I
have this code and I've got it to work by hardcoding values. Since I
have like 500 variables, I'd like to steer clear of hardcoding. What
I need help with is selecting the Column to look in and then finding
the correct value
I know this code doesn't work but it should provide direction to what
I'd like to happen.


Dim CellLoop As Range
Dim CellVal As String
CellLoop = Range("G:G")
CellVal = ActiveCell.FormulaR1C1

'Don't Know how to get this to work
Select Case CellVal in CellLoop
Case 1
InsertPicture "C:\Users\mbramer\Desktop\R_RImages\1.jpg",
_
ActiveCell.Offset(0, -2), True, True
Case 2
InsertPicture "C:\Users\mbramer\Desktop\R_RImages\2.jpg",
_
ActiveCell.Offset(0, -2), True, True
Case Else
MsgBox ("Wrong Values")
End Select


Thanks for your help!
Regards,
Matt

Maybe...

Option Explicit
Sub testme()
Dim myPath As String
Dim myRng As Range
Dim myCell As Range
Dim TestStr As String
Dim myPict As Picture
Dim myPictName As String
Dim myRatio As Double

'change to the correct location of the picture files
myPath = "C:\Users\mbramer\Desktop\R_RImages"
If Right(myPath, 1) < "\" Then
myPath = myPath & "\"
End If

With Worksheets("Sheet1")
.Pictures.Delete 'remove any existing pictures???
Set myRng = .Range("G1", .Cells(.Rows.Count, "G").End(xlUp))

For Each myCell In myRng.Cells
myPictName = myPath & myCell.Value & ".jpg"
TestStr = ""
On Error Resume Next
TestStr = Dir(myPictName)
On Error GoTo 0
If TestStr = "" Then
MsgBox "Pictu " & myPictName & " wasn't found"
Else
Set myPict = .Pictures.Insert(myPictName)
With myCell.Offset(0, 1)
myPict.ShapeRange.LockAspectRatio = msoFalse
myRatio = myPict.Width / myPict.Height
myPict.Top = .Top
myPict.Left = .Left
myPict.Height = .Height
myPict.Width = .Height * myRatio
myPict.Name = "Pict_" & .Address(0, 0)
myPict.ShapeRange.LockAspectRatio = msoTrue
End With
End If
Next myCell
End With
End Sub


=====
It looks in G1:G(lastusedrow) and uses the name in that cell to insert a picture
in column H.

The value in column G shouldn't include the path or the extension. This line
creates the path, filename and extension.

myPictName = myPath & myCell.Value & ".jpg"

If you already have ".jpg" in the cell, you can drop it off this line of code:
myPictName = myPath & myCell.Value




RemyMaza wrote:

I'm trying to insert pics based on values that appear in a cell. I
have this code and I've got it to work by hardcoding values. Since I
have like 500 variables, I'd like to steer clear of hardcoding. What
I need help with is selecting the Column to look in and then finding
the correct value
I know this code doesn't work but it should provide direction to what
I'd like to happen.

Dim CellLoop As Range
Dim CellVal As String
CellLoop = Range("G:G")
CellVal = ActiveCell.FormulaR1C1

'Don't Know how to get this to work
Select Case CellVal in CellLoop
Case 1
InsertPicture "C:\Users\mbramer\Desktop\R_RImages\1.jpg",
_
ActiveCell.Offset(0, -2), True, True
Case 2
InsertPicture "C:\Users\mbramer\Desktop\R_RImages\2.jpg",
_
ActiveCell.Offset(0, -2), True, True
Case Else
MsgBox ("Wrong Values")
End Select

Thanks for your help!
Regards,
Matt

--

Dave Peterson

On May 5, 5:21*pm, Dave Peterson wrote:
Maybe...

Option Explicit
Sub testme()
* * Dim myPath As String
* * Dim myRng As Range
* * Dim myCell As Range
* * Dim TestStr As String
* * Dim myPict As Picture
* * Dim myPictName As String
* * Dim myRatio As Double

* * 'change to the correct location of the picture files
* * myPath = "C:\Users\mbramer\Desktop\R_RImages"
* * If Right(myPath, 1) < "\" Then
* * * * myPath = myPath & "\"
* * End If

* * With Worksheets("Sheet1")
* * * * .Pictures.Delete 'remove any existing pictures???
* * * * Set myRng = .Range("G1", .Cells(.Rows.Count, "G").End(xlUp))

* * * * For Each myCell In myRng.Cells
* * * * * * myPictName = myPath & myCell.Value & ".jpg"
* * * * * * TestStr = ""
* * * * * * On Error Resume Next
* * * * * * TestStr = Dir(myPictName)
* * * * * * On Error GoTo 0
* * * * * * If TestStr = "" Then
* * * * * * * * MsgBox "Pictu " & myPictName & " wasn't found"
* * * * * * Else
* * * * * * * * Set myPict = .Pictures.Insert(myPictName)
* * * * * * * * With myCell.Offset(0, 1)
* * * * * * * * * * myPict.ShapeRange.LockAspectRatio = msoFalse
* * * * * * * * * * myRatio = myPict.Width / myPict.Height
* * * * * * * * * * myPict.Top = .Top
* * * * * * * * * * myPict.Left = .Left
* * * * * * * * * * myPict.Height = .Height
* * * * * * * * * * myPict.Width = .Height * myRatio
* * * * * * * * * * myPict.Name = "Pict_" & .Address(0, 0)
* * * * * * * * * * myPict.ShapeRange.LockAspectRatio = msoTrue
* * * * * * * * End With
* * * * * * End If
* * * * Next myCell
* * End With
End Sub

=====
It looks in G1:G(lastusedrow) and uses the name in that cell to insert a picture
in column H.

The value in column G shouldn't include the path or the extension. *This line
creates the path, filename and extension.

myPictName = myPath & myCell.Value & ".jpg"

If you already have ".jpg" in the cell, you can drop it off this line of code:
myPictName = myPath & myCell.Value





RemyMaza wrote:

I'm trying to insert pics based on values that appear in a cell. *I
have this code and I've got it to work by hardcoding values. *Since I
have like 500 variables, I'd like to steer clear of hardcoding. *What
I need help with is selecting the Column to look in and then finding
the correct value
I know this code doesn't work but it should provide direction to what
I'd like to happen.

* * Dim CellLoop As Range
* * Dim CellVal As String
* * CellLoop = Range("G:G")
* * CellVal = ActiveCell.FormulaR1C1

* * 'Don't Know how to get this to work
* * Select Case CellVal in CellLoop
* * * * Case 1
* * * * * * InsertPicture "C:\Users\mbramer\Desktop\R_RImages\1.jpg",
_
* * * * * * * * ActiveCell.Offset(0, -2), True, True
* * * * Case 2
* * * * * * InsertPicture "C:\Users\mbramer\Desktop\R_RImages\2.jpg",
_
* * * * * * * * ActiveCell.Offset(0, -2), True, True
* * * * Case Else
* * * * * * MsgBox ("Wrong Values")
* * * * End Select

Thanks for your help!
Regards,
Matt

--

Dave Peterson- Hide quoted text -

- Show quoted text -

This is what I've came up with but I don't get an error, I get 5 of
the same "1.jpg" in cell "E1". I think it may have something to do
with the Sub InserPicture but it's not my code and it's a bit over my
head. Thanks for your reply and anyones' input.

Private Sub cmdTest_Click()
Dim myPath As String
Dim CellVal As String
Dim myRng As Range
Dim myCell As Range

myPath = "C:\Users\mbramer\Desktop\R_RImages"
CellVal = ActiveCell.FormulaR1C1

With Worksheets("Sheet1")
Set myRng = .Range("G1", .Cells(.Rows.Count, "G").End(xlUp))

For Each myCell In myRng.Cells
Select Case CellVal
Case "Test"
InsertPicture myPath & "\" & "1.jpg", _
ActiveCell.Offset(0, -2), True, True
Case "Test2"
InsertPicture myPath & "\" & "2.jpg", _
ActiveCell.Offset(0, -2), True, True
Case "Test3"
InsertPicture myPath & "\" & "3.jpg", _
ActiveCell.Offset(0, -2), True, True
Case Else
MsgBox ("No Values")
End Select
Next myCell
End With
End Sub

Sub InsertPicture(PictureFileName As String, TargetCell As Range, _
CenterH As Boolean, CenterV As Boolean)
' inserts a picture at the top left position of TargetCell
' the picture can be centered horizontally and/or vertically
Dim p As Object, 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
' import picture
Set p = ActiveSheet.Pictures.Insert(PictureFileName)
' determine positions
With TargetCell
t = .Top
l = .Left
If CenterH Then
w = .Offset(0, 1).Left - .Left
l = l + w / 2 - p.Width / 2
If l < 1 Then l = 1
End If
If CenterV Then
h = .Offset(1, 0).Top - .Top
t = t + h / 2 - p.Height / 2
If t < 1 Then t = 1
End If
End With
' position picture
With p
.Top = t
.Left = l
End With
Set p = Nothing
End Sub

I think it's more of this line causing the trouble:

InsertPicture myPath & "\" & "2.jpg", _
ActiveCell.Offset(0, -2), True, True

The activecell isn't changing in the new code.

I'd try:

InsertPicture myPath & "\" & "2.jpg", _
mycell.Offset(0, -2), True, True

You have a few lines like this to change.

RemyMaza wrote:

On May 5, 5:21 pm, Dave Peterson wrote:
Maybe...

Option Explicit
Sub testme()
Dim myPath As String
Dim myRng As Range
Dim myCell As Range
Dim TestStr As String
Dim myPict As Picture
Dim myPictName As String
Dim myRatio As Double

'change to the correct location of the picture files
myPath = "C:\Users\mbramer\Desktop\R_RImages"
If Right(myPath, 1) < "\" Then
myPath = myPath & "\"
End If

With Worksheets("Sheet1")
.Pictures.Delete 'remove any existing pictures???
Set myRng = .Range("G1", .Cells(.Rows.Count, "G").End(xlUp))

For Each myCell In myRng.Cells
myPictName = myPath & myCell.Value & ".jpg"
TestStr = ""
On Error Resume Next
TestStr = Dir(myPictName)
On Error GoTo 0
If TestStr = "" Then
MsgBox "Pictu " & myPictName & " wasn't found"
Else
Set myPict = .Pictures.Insert(myPictName)
With myCell.Offset(0, 1)
myPict.ShapeRange.LockAspectRatio = msoFalse
myRatio = myPict.Width / myPict.Height
myPict.Top = .Top
myPict.Left = .Left
myPict.Height = .Height
myPict.Width = .Height * myRatio
myPict.Name = "Pict_" & .Address(0, 0)
myPict.ShapeRange.LockAspectRatio = msoTrue
End With
End If
Next myCell
End With
End Sub

=====
It looks in G1:G(lastusedrow) and uses the name in that cell to insert a picture
in column H.

The value in column G shouldn't include the path or the extension. This line
creates the path, filename and extension.

myPictName = myPath & myCell.Value & ".jpg"

If you already have ".jpg" in the cell, you can drop it off this line of code:
myPictName = myPath & myCell.Value





RemyMaza wrote:

I'm trying to insert pics based on values that appear in a cell. I
have this code and I've got it to work by hardcoding values. Since I
have like 500 variables, I'd like to steer clear of hardcoding. What
I need help with is selecting the Column to look in and then finding
the correct value
I know this code doesn't work but it should provide direction to what
I'd like to happen.

Dim CellLoop As Range
Dim CellVal As String
CellLoop = Range("G:G")
CellVal = ActiveCell.FormulaR1C1

'Don't Know how to get this to work
Select Case CellVal in CellLoop
Case 1
InsertPicture "C:\Users\mbramer\Desktop\R_RImages\1.jpg",
_
ActiveCell.Offset(0, -2), True, True
Case 2
InsertPicture "C:\Users\mbramer\Desktop\R_RImages\2.jpg",
_
ActiveCell.Offset(0, -2), True, True
Case Else
MsgBox ("Wrong Values")
End Select

Thanks for your help!
Regards,
Matt

--

Dave Peterson- Hide quoted text -

- Show quoted text -

This is what I've came up with but I don't get an error, I get 5 of
the same "1.jpg" in cell "E1". I think it may have something to do
with the Sub InserPicture but it's not my code and it's a bit over my
head. Thanks for your reply and anyones' input.

Private Sub cmdTest_Click()
Dim myPath As String
Dim CellVal As String
Dim myRng As Range
Dim myCell As Range

myPath = "C:\Users\mbramer\Desktop\R_RImages"
CellVal = ActiveCell.FormulaR1C1

With Worksheets("Sheet1")
Set myRng = .Range("G1", .Cells(.Rows.Count, "G").End(xlUp))

For Each myCell In myRng.Cells
Select Case CellVal
Case "Test"
InsertPicture myPath & "\" & "1.jpg", _
ActiveCell.Offset(0, -2), True, True
Case "Test2"
InsertPicture myPath & "\" & "2.jpg", _
ActiveCell.Offset(0, -2), True, True
Case "Test3"
InsertPicture myPath & "\" & "3.jpg", _
ActiveCell.Offset(0, -2), True, True
Case Else
MsgBox ("No Values")
End Select
Next myCell
End With
End Sub

Sub InsertPicture(PictureFileName As String, TargetCell As Range, _
CenterH As Boolean, CenterV As Boolean)
' inserts a picture at the top left position of TargetCell
' the picture can be centered horizontally and/or vertically
Dim p As Object, 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
' import picture
Set p = ActiveSheet.Pictures.Insert(PictureFileName)
' determine positions
With TargetCell
t = .Top
l = .Left
If CenterH Then
w = .Offset(0, 1).Left - .Left
l = l + w / 2 - p.Width / 2
If l < 1 Then l = 1
End If
If CenterV Then
h = .Offset(1, 0).Top - .Top
t = t + h / 2 - p.Height / 2
If t < 1 Then t = 1
End If
End With
' position picture
With p
.Top = t
.Left = l
End With
Set p = Nothing
End Sub

--

Dave Peterson

On May 5, 9:24*pm, Dave Peterson wrote:
I think it's more of this line causing the trouble:

* * * * * * * * * * InsertPicture myPath & "\" & "2.jpg", _
* * * * * * * * * * * * ActiveCell.Offset(0, -2), True, True

The activecell isn't changing in the new code.

I'd try:

* * * * * * * * * * InsertPicture myPath & "\" & "2.jpg", _
* * * * * * * * * * * * mycell.Offset(0, -2), True, True

You have a few lines like this to change.





RemyMaza wrote:

On May 5, 5:21 pm, Dave Peterson wrote:
Maybe...

Option Explicit
Sub testme()
* * Dim myPath As String
* * Dim myRng As Range
* * Dim myCell As Range
* * Dim TestStr As String
* * Dim myPict As Picture
* * Dim myPictName As String
* * Dim myRatio As Double

* * 'change to the correct location of the picture files
* * myPath = "C:\Users\mbramer\Desktop\R_RImages"
* * If Right(myPath, 1) < "\" Then
* * * * myPath = myPath & "\"
* * End If

* * With Worksheets("Sheet1")
* * * * .Pictures.Delete 'remove any existing pictures???
* * * * Set myRng = .Range("G1", .Cells(.Rows.Count, "G").End(xlUp))

* * * * For Each myCell In myRng.Cells
* * * * * * myPictName = myPath & myCell.Value & ".jpg"
* * * * * * TestStr = ""
* * * * * * On Error Resume Next
* * * * * * TestStr = Dir(myPictName)
* * * * * * On Error GoTo 0
* * * * * * If TestStr = "" Then
* * * * * * * * MsgBox "Pictu " & myPictName & " wasn't found"
* * * * * * Else
* * * * * * * * Set myPict = .Pictures.Insert(myPictName)
* * * * * * * * With myCell.Offset(0, 1)
* * * * * * * * * * myPict.ShapeRange.LockAspectRatio = msoFalse
* * * * * * * * * * myRatio = myPict.Width / myPict.Height
* * * * * * * * * * myPict.Top = .Top
* * * * * * * * * * myPict.Left = .Left
* * * * * * * * * * myPict.Height = .Height
* * * * * * * * * * myPict.Width = .Height * myRatio
* * * * * * * * * * myPict.Name = "Pict_" & .Address(0, 0)
* * * * * * * * * * myPict.ShapeRange.LockAspectRatio = msoTrue
* * * * * * * * End With
* * * * * * End If
* * * * Next myCell
* * End With
End Sub

=====
It looks in G1:G(lastusedrow) and uses the name in that cell to insert a picture
in column H.

The value in column G shouldn't include the path or the extension. *This line
creates the path, filename and extension.

myPictName = myPath & myCell.Value & ".jpg"

If you already have ".jpg" in the cell, you can drop it off this line of code:
myPictName = myPath & myCell.Value

RemyMaza wrote:

I'm trying to insert pics based on values that appear in a cell. *I
have this code and I've got it to work by hardcoding values. *Since I
have like 500 variables, I'd like to steer clear of hardcoding. *What
I need help with is selecting the Column to look in and then finding
the correct value
I know this code doesn't work but it should provide direction to what
I'd like to happen.

* * Dim CellLoop As Range
* * Dim CellVal As String
* * CellLoop = Range("G:G")
* * CellVal = ActiveCell.FormulaR1C1

* * 'Don't Know how to get this to work
* * Select Case CellVal in CellLoop
* * * * Case 1
* * * * * * InsertPicture "C:\Users\mbramer\Desktop\R_RImages\1.jpg",
_
* * * * * * * * ActiveCell.Offset(0, -2), True, True
* * * * Case 2
* * * * * * InsertPicture "C:\Users\mbramer\Desktop\R_RImages\2.jpg",
_
* * * * * * * * ActiveCell.Offset(0, -2), True, True
* * * * Case Else
* * * * * * MsgBox ("Wrong Values")
* * * * End Select

Thanks for your help!
Regards,
Matt

--

Dave Peterson- Hide quoted text -

- Show quoted text -

This is what I've came up with but I don't get an error, I get 5 of
the same "1.jpg" in cell "E1". *I think it may have something to do
with the Sub InserPicture but it's not my code and it's a bit over my
head. *Thanks for your reply and anyones' input.

Private Sub cmdTest_Click()
* * Dim myPath As String
* * Dim CellVal As String
* * Dim myRng As Range
* * Dim myCell As Range

* * myPath = "C:\Users\mbramer\Desktop\R_RImages"
* * CellVal = ActiveCell.FormulaR1C1

* * With Worksheets("Sheet1")
* * * * Set myRng = .Range("G1", .Cells(.Rows.Count, "G").End(xlUp))

* * * * For Each myCell In myRng.Cells
* * * * * * Select Case CellVal
* * * * * * Case "Test"
* * * * * * * * * * InsertPicture myPath & "\" & "1.jpg", _
* * * * * * * * * * * * ActiveCell.Offset(0, -2), True, True
* * * * * * Case "Test2"
* * * * * * * * * * InsertPicture myPath & "\" & "2.jpg", _
* * * * * * * * * * * * ActiveCell.Offset(0, -2), True, True
* * * * * * Case "Test3"
* * * * * * * * * * InsertPicture myPath & "\" & "3.jpg", _
* * * * * * * * * * * * ActiveCell.Offset(0, -2), True, True
* * * * * * Case Else
* * * * * * * * MsgBox ("No Values")
* * * * * * End Select
* * * * Next myCell
* * End With
End Sub

Sub InsertPicture(PictureFileName As String, TargetCell As Range, _
* * CenterH As Boolean, CenterV As Boolean)
' inserts a picture at the top left position of TargetCell
' the picture can be centered horizontally and/or vertically
Dim p As Object, 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
* * ' import picture
* * Set p = ActiveSheet.Pictures.Insert(PictureFileName)
* * ' determine positions
* * With TargetCell
* * * * t = .Top
* * * * l = .Left
* * * * If CenterH Then
* * * * * * w = .Offset(0, 1).Left - .Left
* * * * * * l = l + w / 2 - p.Width / 2
* * * * * * If l < 1 Then l = 1
* * * * End If
* * * * If CenterV Then
* * * * * * h = .Offset(1, 0).Top - .Top
* * * * * * t = t + h / 2 - p.Height / 2
* * * * * * If t < 1 Then t = 1
* * * * End If
* * End With
* * ' position picture
* * With p
* * * * .Top = t
* * * * .Left = l
* * End With
* * Set p = Nothing
End Sub

--

Dave Peterson- Hide quoted text -

- Show quoted text -

We are getting real close. I've changed the code with your input.
Now I get the same pic for each line that has a value. I put Test,
Test2, Test3, and the word Input in Column G. I get pic 1.jpg for
every line. I deleted the pic thinking that there were multiple icons
there but this is the only one being inserted. I changed this line:

CellVal = myCell.FormulaR1C1

But that gave me errors so I changed it back to:

CellVal = ActiveCell.FormulaR1C1

So SO SO close... Thanks so much for your help. I can't think of why
this won't work, but then again, I don't really program in Excel too
often.

Regards,
Matt

Since you're cycling through a bunch of cells, you don't want to use something
like:

CellVal = ActiveCell.FormulaR1C1

This will never change. Even if you change it to mycell.formular1c1, then you'd
have to move it into the loop so that it knows what mycell is and so that it
changes for each cell in that loop.

I dropped the line and variable and made a couple of changes to both the
cmdTest_click subroutine and to the insertpicture subroutine.


Option Explicit
Private Sub cmdTest_Click()
Dim myPath As String
Dim myRng As Range
Dim myCell As Range

myPath = "C:\Users\mbramer\Desktop\R_RImages"

With Worksheets("Sheet1")
Set myRng = .Range("G1", .Cells(.Rows.Count, "G").End(xlUp))

For Each myCell In myRng.Cells
Select Case LCase(myCell.Value)
Case LCase("Test")
InsertPicture myPath & "\" & "1.jpg", _
myCell.Offset(0, -2), True, True
Case LCase("Test2")
InsertPicture myPath & "\" & "2.jpg", _
myCell.Offset(0, -2), True, True
Case LCase("Test3")
InsertPicture myPath & "\" & "3.jpg", _
myCell.Offset(0, -2), True, True
Case Else
MsgBox "No Values in: " & myCell.Address(0, 0)
End Select
Next myCell
End With
End Sub

Sub InsertPicture(PictureFileName As String, TargetCell As Range, _
CenterH As Boolean, CenterV As Boolean)
' inserts a picture at the top left position of TargetCell
' the picture can be centered horizontally and/or vertically
Dim p As Object, t As Double, l As Double, w As Double, h As Double
If TypeName(TargetCell.Parent) < "Worksheet" Then Exit Sub
If Dir(PictureFileName) = "" Then Exit Sub
' import picture
Set p = TargetCell.Parent.Pictures.Insert(PictureFileName)
' determine positions
With TargetCell
t = .Top
l = .Left
If CenterH Then
w = .Offset(0, 1).Left - .Left
l = l + w / 2 - p.Width / 2
If l < 1 Then l = 1
End If
If CenterV Then
h = .Offset(1, 0).Top - .Top
t = t + h / 2 - p.Height / 2
If t < 1 Then t = 1
End If
End With
' position picture
With p
.Top = t
.Left = l
End With
Set p = Nothing
End Sub



RemyMaza wrote:

On May 5, 9:24 pm, Dave Peterson wrote:
I think it's more of this line causing the trouble:

InsertPicture myPath & "\" & "2.jpg", _
ActiveCell.Offset(0, -2), True, True

The activecell isn't changing in the new code.

I'd try:

InsertPicture myPath & "\" & "2.jpg", _
mycell.Offset(0, -2), True, True

You have a few lines like this to change.





RemyMaza wrote:

On May 5, 5:21 pm, Dave Peterson wrote:
Maybe...

Option Explicit
Sub testme()
Dim myPath As String
Dim myRng As Range
Dim myCell As Range
Dim TestStr As String
Dim myPict As Picture
Dim myPictName As String
Dim myRatio As Double

'change to the correct location of the picture files
myPath = "C:\Users\mbramer\Desktop\R_RImages"
If Right(myPath, 1) < "\" Then
myPath = myPath & "\"
End If

With Worksheets("Sheet1")
.Pictures.Delete 'remove any existing pictures???
Set myRng = .Range("G1", .Cells(.Rows.Count, "G").End(xlUp))

For Each myCell In myRng.Cells
myPictName = myPath & myCell.Value & ".jpg"
TestStr = ""
On Error Resume Next
TestStr = Dir(myPictName)
On Error GoTo 0
If TestStr = "" Then
MsgBox "Pictu " & myPictName & " wasn't found"
Else
Set myPict = .Pictures.Insert(myPictName)
With myCell.Offset(0, 1)
myPict.ShapeRange.LockAspectRatio = msoFalse
myRatio = myPict.Width / myPict.Height
myPict.Top = .Top
myPict.Left = .Left
myPict.Height = .Height
myPict.Width = .Height * myRatio
myPict.Name = "Pict_" & .Address(0, 0)
myPict.ShapeRange.LockAspectRatio = msoTrue
End With
End If
Next myCell
End With
End Sub

=====
It looks in G1:G(lastusedrow) and uses the name in that cell to insert a picture
in column H.

The value in column G shouldn't include the path or the extension. This line
creates the path, filename and extension.

myPictName = myPath & myCell.Value & ".jpg"

If you already have ".jpg" in the cell, you can drop it off this line of code:
myPictName = myPath & myCell.Value

RemyMaza wrote:

I'm trying to insert pics based on values that appear in a cell. I
have this code and I've got it to work by hardcoding values. Since I
have like 500 variables, I'd like to steer clear of hardcoding. What
I need help with is selecting the Column to look in and then finding
the correct value
I know this code doesn't work but it should provide direction to what
I'd like to happen.

Dim CellLoop As Range
Dim CellVal As String
CellLoop = Range("G:G")
CellVal = ActiveCell.FormulaR1C1

'Don't Know how to get this to work
Select Case CellVal in CellLoop
Case 1
InsertPicture "C:\Users\mbramer\Desktop\R_RImages\1.jpg",
_
ActiveCell.Offset(0, -2), True, True
Case 2
InsertPicture "C:\Users\mbramer\Desktop\R_RImages\2.jpg",
_
ActiveCell.Offset(0, -2), True, True
Case Else
MsgBox ("Wrong Values")
End Select

Thanks for your help!
Regards,
Matt

--

Dave Peterson- Hide quoted text -

- Show quoted text -

This is what I've came up with but I don't get an error, I get 5 of
the same "1.jpg" in cell "E1". I think it may have something to do
with the Sub InserPicture but it's not my code and it's a bit over my
head. Thanks for your reply and anyones' input.

Private Sub cmdTest_Click()
Dim myPath As String
Dim CellVal As String
Dim myRng As Range
Dim myCell As Range

myPath = "C:\Users\mbramer\Desktop\R_RImages"
CellVal = ActiveCell.FormulaR1C1

With Worksheets("Sheet1")
Set myRng = .Range("G1", .Cells(.Rows.Count, "G").End(xlUp))

For Each myCell In myRng.Cells
Select Case CellVal
Case "Test"
InsertPicture myPath & "\" & "1.jpg", _
ActiveCell.Offset(0, -2), True, True
Case "Test2"
InsertPicture myPath & "\" & "2.jpg", _
ActiveCell.Offset(0, -2), True, True
Case "Test3"
InsertPicture myPath & "\" & "3.jpg", _
ActiveCell.Offset(0, -2), True, True
Case Else
MsgBox ("No Values")
End Select
Next myCell
End With
End Sub

Sub InsertPicture(PictureFileName As String, TargetCell As Range, _
CenterH As Boolean, CenterV As Boolean)
' inserts a picture at the top left position of TargetCell
' the picture can be centered horizontally and/or vertically
Dim p As Object, 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
' import picture
Set p = ActiveSheet.Pictures.Insert(PictureFileName)
' determine positions
With TargetCell
t = .Top
l = .Left
If CenterH Then
w = .Offset(0, 1).Left - .Left
l = l + w / 2 - p.Width / 2
If l < 1 Then l = 1
End If
If CenterV Then
h = .Offset(1, 0).Top - .Top
t = t + h / 2 - p.Height / 2
If t < 1 Then t = 1
End If
End With
' position picture
With p
.Top = t
.Left = l
End With
Set p = Nothing
End Sub

--

Dave Peterson- Hide quoted text -

- Show quoted text -

We are getting real close. I've changed the code with your input.
Now I get the same pic for each line that has a value. I put Test,
Test2, Test3, and the word Input in Column G. I get pic 1.jpg for
every line. I deleted the pic thinking that there were multiple icons
there but this is the only one being inserted. I changed this line:

CellVal = myCell.FormulaR1C1

But that gave me errors so I changed it back to:

CellVal = ActiveCell.FormulaR1C1

So SO SO close... Thanks so much for your help. I can't think of why
this won't work, but then again, I don't really program in Excel too
often.

Regards,
Matt

--

Dave Peterson

On May 5, 9:24*pm, Dave Peterson wrote:
I think it's more of this line causing the trouble:

* * * * * * * * * * InsertPicture myPath & "\" & "2.jpg", _
* * * * * * * * * * * * ActiveCell.Offset(0, -2), True, True

The activecell isn't changing in the new code.

I'd try:

* * * * * * * * * * InsertPicture myPath & "\" & "2.jpg", _
* * * * * * * * * * * * mycell.Offset(0, -2), True, True

You have a few lines like this to change.





RemyMaza wrote:

On May 5, 5:21 pm, Dave Peterson wrote:
Maybe...

Option Explicit
Sub testme()
* * Dim myPath As String
* * Dim myRng As Range
* * Dim myCell As Range
* * Dim TestStr As String
* * Dim myPict As Picture
* * Dim myPictName As String
* * Dim myRatio As Double

* * 'change to the correct location of the picture files
* * myPath = "C:\Users\mbramer\Desktop\R_RImages"
* * If Right(myPath, 1) < "\" Then
* * * * myPath = myPath & "\"
* * End If

* * With Worksheets("Sheet1")
* * * * .Pictures.Delete 'remove any existing pictures???
* * * * Set myRng = .Range("G1", .Cells(.Rows.Count, "G").End(xlUp))

* * * * For Each myCell In myRng.Cells
* * * * * * myPictName = myPath & myCell.Value & ".jpg"
* * * * * * TestStr = ""
* * * * * * On Error Resume Next
* * * * * * TestStr = Dir(myPictName)
* * * * * * On Error GoTo 0
* * * * * * If TestStr = "" Then
* * * * * * * * MsgBox "Pictu " & myPictName & " wasn't found"
* * * * * * Else
* * * * * * * * Set myPict = .Pictures.Insert(myPictName)
* * * * * * * * With myCell.Offset(0, 1)
* * * * * * * * * * myPict.ShapeRange.LockAspectRatio = msoFalse
* * * * * * * * * * myRatio = myPict.Width / myPict.Height
* * * * * * * * * * myPict.Top = .Top
* * * * * * * * * * myPict.Left = .Left
* * * * * * * * * * myPict.Height = .Height
* * * * * * * * * * myPict.Width = .Height * myRatio
* * * * * * * * * * myPict.Name = "Pict_" & .Address(0, 0)
* * * * * * * * * * myPict.ShapeRange.LockAspectRatio = msoTrue
* * * * * * * * End With
* * * * * * End If
* * * * Next myCell
* * End With
End Sub

=====
It looks in G1:G(lastusedrow) and uses the name in that cell to insert a picture
in column H.

The value in column G shouldn't include the path or the extension. *This line
creates the path, filename and extension.

myPictName = myPath & myCell.Value & ".jpg"

If you already have ".jpg" in the cell, you can drop it off this line of code:
myPictName = myPath & myCell.Value

RemyMaza wrote:

I'm trying to insert pics based on values that appear in a cell. *I
have this code and I've got it to work by hardcoding values. *Since I
have like 500 variables, I'd like to steer clear of hardcoding. *What
I need help with is selecting the Column to look in and then finding
the correct value
I know this code doesn't work but it should provide direction to what
I'd like to happen.

* * Dim CellLoop As Range
* * Dim CellVal As String
* * CellLoop = Range("G:G")
* * CellVal = ActiveCell.FormulaR1C1

* * 'Don't Know how to get this to work
* * Select Case CellVal in CellLoop
* * * * Case 1
* * * * * * InsertPicture "C:\Users\mbramer\Desktop\R_RImages\1.jpg",
_
* * * * * * * * ActiveCell.Offset(0, -2), True, True
* * * * Case 2
* * * * * * InsertPicture "C:\Users\mbramer\Desktop\R_RImages\2.jpg",
_
* * * * * * * * ActiveCell.Offset(0, -2), True, True
* * * * Case Else
* * * * * * MsgBox ("Wrong Values")
* * * * End Select

Thanks for your help!
Regards,
Matt

--

Dave Peterson- Hide quoted text -

- Show quoted text -

This is what I've came up with but I don't get an error, I get 5 of
the same "1.jpg" in cell "E1". *I think it may have something to do
with the Sub InserPicture but it's not my code and it's a bit over my
head. *Thanks for your reply and anyones' input.

Private Sub cmdTest_Click()
* * Dim myPath As String
* * Dim CellVal As String
* * Dim myRng As Range
* * Dim myCell As Range

* * myPath = "C:\Users\mbramer\Desktop\R_RImages"
* * CellVal = ActiveCell.FormulaR1C1

* * With Worksheets("Sheet1")
* * * * Set myRng = .Range("G1", .Cells(.Rows.Count, "G").End(xlUp))

* * * * For Each myCell In myRng.Cells
* * * * * * Select Case CellVal
* * * * * * Case "Test"
* * * * * * * * * * InsertPicture myPath & "\" & "1.jpg", _
* * * * * * * * * * * * ActiveCell.Offset(0, -2), True, True
* * * * * * Case "Test2"
* * * * * * * * * * InsertPicture myPath & "\" & "2.jpg", _
* * * * * * * * * * * * ActiveCell.Offset(0, -2), True, True
* * * * * * Case "Test3"
* * * * * * * * * * InsertPicture myPath & "\" & "3.jpg", _
* * * * * * * * * * * * ActiveCell.Offset(0, -2), True, True
* * * * * * Case Else
* * * * * * * * MsgBox ("No Values")
* * * * * * End Select
* * * * Next myCell
* * End With
End Sub

Sub InsertPicture(PictureFileName As String, TargetCell As Range, _
* * CenterH As Boolean, CenterV As Boolean)
' inserts a picture at the top left position of TargetCell
' the picture can be centered horizontally and/or vertically
Dim p As Object, 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
* * ' import picture
* * Set p = ActiveSheet.Pictures.Insert(PictureFileName)
* * ' determine positions
* * With TargetCell
* * * * t = .Top
* * * * l = .Left
* * * * If CenterH Then
* * * * * * w = .Offset(0, 1).Left - .Left
* * * * * * l = l + w / 2 - p.Width / 2
* * * * * * If l < 1 Then l = 1
* * * * End If
* * * * If CenterV Then
* * * * * * h = .Offset(1, 0).Top - .Top
* * * * * * t = t + h / 2 - p.Height / 2
* * * * * * If t < 1 Then t = 1
* * * * End If
* * End With
* * ' position picture
* * With p
* * * * .Top = t
* * * * .Left = l
* * End With
* * Set p = Nothing
End Sub

--

Dave Peterson- Hide quoted text -

- Show quoted text -

I just tried IF statements and got the same result as I did with the
Case statements. Seems like my variable isn't being looked at for
some reason. Here's the code I tried:

If CellVal = "Test" Then
InsertPicture myPath & "\" & "2.jpg", _
myCell.Offset(0, -2), True, True
ElseIf CellVal = "Test2" Then
InsertPicture myPath & "\" & "4.jpg", _
myCell.Offset(0, -2), True, True
ElseIf CellVal = "Test3" Then
InsertPicture myPath & "\" & "6.jpg", _
myCell.Offset(0, -2), True, True

Same result though :-( Thanks again for your help Dave. You keep
earning your 5 stars here!