View Single Post
  #7   Report Post  
Posted to microsoft.public.excel.misc
Ken Johnson
 
Posts: n/a
Default Graphics: Same Picture on several sheets

Hi Bruce,

I reread your original post only to discover I've basically got things
face about apex.

I just had to change it a little so that you can use any sheet as the
sheet with all the pictures (only one will be visible though once the
code has been activated) and the cell that has the picture controlling
value.
Just paste the following code into Sheet5's code module. You get to
that code module by right clicking the Sheet5 sheet tab then selecting
"View Code" from the popup menu.

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$A$1" Then
'$A$1 is the address of the cell whose value determines
'which picture is visible. Change to suit your needs.
'Error will occur if $s omitted
Application.ScreenUpdating = False
Dim NewPicHeight As Single
Dim NewPicWidth As Single
Dim NewPicLeft As Single
Dim NewPicTop As Single
Dim NewPicName As String
Dim SheetWithAllPics As String
SheetWithAllPics = Me.Name
DeleteOldPic (SheetWithAllPics)
Dim ncPics As New Collection
Dim shp As Shape
Dim Sht As Worksheet
For Each shp In Me.Shapes
If Left(shp.Name, 5) = "MyPic" Then
ncPics.Add Item:=shp
End If
Next shp
For Each shp In ncPics
If Right(shp.Name, Len(Target.Value)) _
= CStr(Target.Value) Then
shp.Visible = True
NewPicHeight = shp.Height
NewPicWidth = shp.Width
NewPicLeft = shp.Left
NewPicTop = shp.Top
shp.Copy
NewPicName = shp.Name
For Each Sht In ActiveWorkbook.Worksheets
If Sht.Name < Me.Name Then
With Sht
.Paste
.Activate
.Range("A1").Select
End With
Me.Activate
End If
Next Sht
For Each Sht In ActiveWorkbook.Worksheets
If Sht.Name < Me.Name Then
With Sht.Shapes(NewPicName)
.Height = NewPicHeight
.Width = NewPicWidth
.Top = NewPicTop
.Left = NewPicLeft
.Name = "OldPic"
End With
End If
Next Sht
Else: shp.Visible = False
End If
Next shp
End If
End Sub

Public Sub DeleteOldPic(SkipSheet As String)
Dim Sht As Worksheet
For Each Sht In ActiveWorkbook.Worksheets
If Sht.Name < SkipSheet Then
On Error Resume Next
Sht.Shapes("OldPic").Delete
End If
Next Sht
End Sub

Ken Johnson