Hi Bruce,

One thing my code hasn't allowed for is the need for different picture
dimensions on one or more of the other sheets (Sheets 1 to 4).
I've added four new variables...

HeightFactor
WidthFactor
LeftAdjust
TopAdjust

and a Select case that depends on the names of sheets requiring that
the MyPic be of different size and/or position.
This part of the code will have to be edited to suit your needs.
You only have to change the sheet names at each Case line and tweak the
Factors and Adjusts values to get the MyPics correctly sized and
positioned. If only one sheet, say Sheet3, needs MyPics to be altered
this way then you only need two blocks of Case code, Case "Sheet3" and
Case Else. Extra blocks will have to be included depending on how many
sheets require MyPic changes.

At the moment the code is set up for each MyPic to be 10% smaller and
36 points further down the sheet on a sheet that has been renamed "My
Sheet" (originally named Sheet1) and 20% larger and 48 points closer to
the left side of Sheet3 (not renamed), and it looks like...


For Each Sht In ActiveWorkbook.Worksheets
If Sht.Name < Me.Name Then
Select Case Sht.Name
Case "My Sheet"
HeightFactor = 0.9
WidthFactor = 0.9
LeftAdjust = 0
TopAdjust = 36
Case "Sheet3"
HeightFactor = 1.2
WidthFactor = 1.2
LeftAdjust = -48
TopAdjust = 0
Case Else
HeightFactor = 1
WidthFactor = 1
LeftAdjust = 0
TopAdjust = 0
End Select
With Sht.Shapes(NewPicName)
.Height = NewPicHeight * HeightFactor
.Width = NewPicWidth * WidthFactor
.Top = NewPicTop + TopAdjust
.Left = NewPicLeft + LeftAdjust
.Name = "OldPic"
End With
End If
Next Sht

I hope this all makes sense.

Here is the complete code including the above changes plus some code
comments...

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 HeightFactor As Single
Dim WidthFactor As Single
Dim LeftAdjust As Single
Dim TopAdjust 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
'Paste MyPics onto other worksheets
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
'Control MyPic's dimensions and positions.
'Factors = 1 and Adjusts = 0 for no change.
'Alter their values to suit your needs.
'MyPic will be distorted if Factors are
'not equal.
'Edit strings at each Case line to name
'of a sheet on which MyPic needs change in
'size and/or position.
'Tweak the Factor and Adjust(pts) values
For Each Sht In ActiveWorkbook.Worksheets
If Sht.Name < Me.Name Then
Select Case Sht.Name
Case "My Sheet"
HeightFactor = 0.9 'height reduced 10%
WidthFactor = 0.9 'width reduced 10%
LeftAdjust = 0
TopAdjust = 36 '36 pts lower
Case "Sheet3"
HeightFactor = 1.2 '20% taller
WidthFactor = 1.2 '20% wider
LeftAdjust = -48 '48 pts to left
TopAdjust = 0
Case Else
HeightFactor = 1
WidthFactor = 1
LeftAdjust = 0
TopAdjust = 0
End Select
With Sht.Shapes(NewPicName)
.Height = NewPicHeight * HeightFactor
.Width = NewPicWidth * WidthFactor
.Top = NewPicTop + TopAdjust
.Left = NewPicLeft + LeftAdjust
.Name = "OldPic"
End With
End If
Next Sht
Else: shp.Visible = False
End If
Next shp
End If
End Sub

Ken Johnson