Can this be done.
I have cells with Team Names.
I want a vb script something like this.
[VBA]
Private Sub Helmets()
If Range("C3:AR33").Value = "Washington Redskins" Then
ActiveSheet.Shapes("Redskins").Select
.Copy
.Paste
End If
End Sub
[/VBA]
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?
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?
____________________________________________
Nihil simul inventum est et perfectum
Abusus non tollit usum
Last night I dreamed of a small consolation enjoyed only by the blind: Nobody knows the trouble I've not seen!
James Thurber
Well I have to run this for each Team. So I am guessing on carrying on.
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?
Bump!
[vba]
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
[/vba]
____________________________________________
Nihil simul inventum est et perfectum
Abusus non tollit usum
Last night I dreamed of a small consolation enjoyed only by the blind: Nobody knows the trouble I've not seen!
James Thurber
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?
Would this be affected because of Office 2007?
That was added for my testing, just remove that line.
____________________________________________
Nihil simul inventum est et perfectum
Abusus non tollit usum
Last night I dreamed of a small consolation enjoyed only by the blind: Nobody knows the trouble I've not seen!
James Thurber
Ok i got this
[VBA]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[/VBA]
It's giving me a Next without For Error.
Where would I add all the teams?
Something like this
[VBA]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
[/VBA]
[vba]
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
[/vba]
____________________________________________
Nihil simul inventum est et perfectum
Abusus non tollit usum
Last night I dreamed of a small consolation enjoyed only by the blind: Nobody knows the trouble I've not seen!
James Thurber
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?
Bump
[vba]
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
[/vba]
____________________________________________
Nihil simul inventum est et perfectum
Abusus non tollit usum
Last night I dreamed of a small consolation enjoyed only by the blind: Nobody knows the trouble I've not seen!
James Thurber
If your naming convention is consistent,
try
[vba]
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
[/vba]
MVP (Excel 2008-2010)
Post a workbook with sample data and layout if you want a quicker solution.
To help indent your macros try Smart Indent
Please remember to mark threads 'Solved'
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.
It seems to work in Office 2003. How can I get to Center the shape in the cell?
(Totonto) causes a glitch, otherwise this works for me. (Office 2000)
[vba]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[/vba]
MVP (Excel 2008-2010)
Post a workbook with sample data and layout if you want a quicker solution.
To help indent your macros try Smart Indent
Please remember to mark threads 'Solved'
Posting Permissions
Reply With Quote
