PDA

View Full Version : Paste Picture based on cell value



Emoncada
08-29-2008, 06:12 AM
Can this be done.

I have cells with Team Names.
I want a vb script something like this.


Private Sub Helmets()

If Range("C3:AR33").Value = "Washington Redskins" Then
ActiveSheet.Shapes("Redskins").Select
.Copy
.Paste
End If
End Sub

I want to do this for every team something like this.
So if the Cell has the Team Name "New York Giants" then i will paste the Shapes("Giants")

Can this be done like this?

Bob Phillips
08-29-2008, 06:17 AM
You are checking a range of cells for a value. You need to check each I assume, but do you want to past the picture when match is made and end, or carry on for any more?

Emoncada
08-29-2008, 06:19 AM
Well I have to run this for each Team. So I am guessing on carrying on.

Emoncada
08-29-2008, 06:20 AM
I want to paste the picture in the cell that matches the value.
So Washington Redskins will get the ("Redskins") Picture.
How can I have it check the range cell by cell?

Emoncada
08-29-2008, 10:55 AM
Bump!

Bob Phillips
08-29-2008, 01:41 PM
Private Sub Helmets()
Dim cell As Range

With ActiveSheet

For Each cell In Range("C3:AR33")

Debug.Assert cell.Address <> "$E$8"
Select Case cell.Value

Case "Washington Redskins":
.Shapes("Redskins").Left = cell.Left
.Shapes("Redskins").Top = cell.Top
End Select
Next cell
End With
End Sub

Emoncada
08-29-2008, 02:05 PM
It's giving me an error on Debug.Assert cell.Address <> "$E$8"
Why is it "$E$8" or am I supposed to change that to match something?

Emoncada
08-29-2008, 02:21 PM
Would this be affected because of Office 2007?

Bob Phillips
08-29-2008, 02:23 PM
That was added for my testing, just remove that line.

Emoncada
08-29-2008, 02:39 PM
Ok i got this

Private Sub Helmets()
Dim cell As Range

With ActiveSheet

For Each cell In Range("C3:AR33")

Select Case cell.Value

Case "Washington Redskins":
.Shapes("Redskins").Left = cell.Left
.Shapes("Redskins").Top = cell.Top
Next cell
End Select
End With
End Sub

It's giving me a Next without For Error.

Where would I add all the teams?

Emoncada
08-29-2008, 02:42 PM
Something like this

Private Sub Helmets()
Dim cell As Range

With ActiveSheet

For Each cell In Range("C3:AR33")

'Debug.Assert cell.Address <> "$E$8"
Select Case cell.Value

Case "Washington Redskins":
.Shapes("Redskins").Left = cell.Left
.Shapes("Redskins").Top = cell.Top

Case "San Francisco 49ers":
.Shapes("49ers").Left = cell.Left
.Shapes("49ers").Top = cell.Top

Case "Chicago Bears":
.Shapes("Bears").Left = cell.Left
.Shapes("Bears").Top = cell.Top

Case "Cincinnati Bengals":
.Shapes("Bengals").Left = cell.Left
.Shapes("Bengals").Top = cell.Top

Case "Buffalo Bills":
.Shapes("Bills").Left = cell.Left
.Shapes("Bills").Top = cell.Top

Next cell
End Select
End With
End Sub

Bob Phillips
08-29-2008, 05:18 PM
Private Sub Helmets()
Dim cell As Range

With ActiveSheet

For Each cell In Range("C3:AR33")

'Debug.Assert cell.Address <> "$E$8"
Select Case cell.Value

Case "Washington Redskins":
.Shapes("Redskins").Left = cell.Left
.Shapes("Redskins").Top = cell.Top

Case "San Francisco 49ers":
.Shapes("49ers").Left = cell.Left
.Shapes("49ers").Top = cell.Top

Case "Chicago Bears":
.Shapes("Bears").Left = cell.Left
.Shapes("Bears").Top = cell.Top

Case "Cincinnati Bengals":
.Shapes("Bengals").Left = cell.Left
.Shapes("Bengals").Top = cell.Top

Case "Buffalo Bills":
.Shapes("Bills").Left = cell.Left
.Shapes("Bills").Top = cell.Top
End Select
Next cell
End With
End Sub

Emoncada
08-29-2008, 06:12 PM
That seems to work, but I need it to copy it into each cell. It's currently seems to move the picture into the last match. Can this be done?

Emoncada
08-31-2008, 12:01 PM
Bump

Bob Phillips
08-31-2008, 01:52 PM
Private Sub Helmets()
Dim cell As Range
Dim shpRedskins As Shape
Dim shp49ers As Shape
Dim shpBears As Shape
Dim shpBengals As Shape
Dim shpBills As Shape
Dim shp As Shape

With ActiveSheet

Set shpRedskins = .Shapes("Redskins")
Set shp49ers = .Shapes("49ers")
Set shpBears = .Shapes("Bears")
Set shpBengals = .Shapes("Bengals")
Set shpBills = .Shapes("Bills")
For Each cell In Range("C3:AR33")

'Debug.Assert cell.Address <> "$E$8"
Select Case cell.Value

Case "Washington Redskins":

shpRedskins.Copy
.Paste
Selection.Left = cell.Left
Selection.Top = cell.Top

Case "San Francisco 49ers":

shp49ers.Copy
.Paste
Selection.Left = cell.Left
Selection.Top = cell.Top

Case "Chicago Bears":

shpBears.Copy
.Paste
Selection.Left = cell.Left
Selection.Top = cell.Top

Case "Cincinnati Bengals":

shpBengals.Copy
.Paste
Selection.Left = cell.Left
Selection.Top = cell.Top

Case "Buffalo Bills":

shpBills.Copy
.Paste
Selection.Left = cell.Left
Selection.Top = cell.Top
End Select

Next cell
End With
End Sub

mdmackillop
08-31-2008, 01:53 PM
If your naming convention is consistent,
try

Option Explicit
Private Sub Helmets()
Dim cell As Range
Dim PicName As String
Application.ScreenUpdating = False
With ActiveSheet
For Each cell In Range("C3:AR33")
PicName = Split(cell)(UBound(Split(cell)))
With ActiveSheet
.Shapes(PicName).Copy
ActiveSheet.Paste
With Selection
.Left = cell.Left
.Top = cell.Top
End With
End With
Next cell
End With
Application.ScreenUpdating = True
End Sub

Emoncada
09-03-2008, 06:01 AM
xld that seemed to create a vertical line down the spreadsheet with all the pictures repeated. it doesn't seem to be going into the cells except for a couple. Attached is the spreadsheet.

mdmackillop that didn't work either.

Emoncada
09-03-2008, 06:12 AM
It seems to work in Office 2003. How can I get to Center the shape in the cell?

mdmackillop
09-03-2008, 06:55 AM
(Totonto) causes a glitch, otherwise this works for me. (Office 2000)

Option Explicit
Sub Helmets()
Dim cell As Range
Dim PicName As String
Dim PicWidth As Single
Dim CellWidth As Single
Application.ScreenUpdating = False
With ActiveSheet
For Each cell In Range("C3:AR65")
CellWidth = cell.Width
If cell <> "" And cell <> "BYE" And cell.Row Mod 2 = 1 Then
PicName = Split(cell)(UBound(Split(cell)))
With ActiveSheet
On Error GoTo Nextone
.Shapes(PicName).Copy
ActiveSheet.Paste
With Selection
.Left = cell.Left + (cell.Width - ActiveSheet.Shapes(PicName).Width) / 2
.Top = cell.Top
End With
Nextone:
End With
End If
Next cell
End With
Application.ScreenUpdating = True
End Sub