Solved: Put picture in top right corner of cell

[perhol]

At my work, a public institution for physically and mentally handicapped, we use a calendar to, among other things to show birthdays.
Birthday is marked by name, age and a flag.
The flag is copied from another sheet. The problem is that many are using the sheet, and most do not really know what they are doing.
I have protected file as far as I can without locking the file completely.
Nevertheless, someoneone find the sheet with the flag. If it is moved around, it will not be placed in the right place in the destination cell.
Can you help me with the code so the flag is always placed in the upper right corner of the cell?
Here is the code that copies the flags from a sheet and paste it on 2 other sheets:

[vba]Sub SætFlag()
Application.ScreenUpdating = False
'Code for copying flag
Ark2.Activate 'Ark2 is Danish for Sheet2
ActiveSheet.Unprotect
ActiveSheet.DrawingObjects("Billede 1").Copy '"Billede 1" is Danish for "Picture 1"
'Code for deleting existing flags
Ark1.Activate 'Ark1 is Danish for Sheet1
ActiveSheet.Unprotect
For Each sh In ActiveSheet.Shapes
If sh.Type = msoPicture Then
sh.Delete
End If
Next
'Code for pasting new flags with birthdays
Range("L35").Select
For Each c In Range("D333, H3:H33, L3:L33, P3:P33, T3:T33, X3:X33, AB3:AB33, AF3:AF33, AJ3:AJ33, AN3:AN33, AR3:AR33, AV3:Av33")
CellValue = c.Value
If CellValue Like "*år.*" Then
c.Activate
ActiveSheet.Paste
Selection.ShapeRange.IncrementLeft 42
Selection.ShapeRange.IncrementTop -3
End If
Next
Range("L35").Activate
ActiveSheet.Protect
'Code for copying flag
Ark2.Activate 'Ark2 is Danish for Sheet2
ActiveSheet.DrawingObjects("Billede 1").Copy
'Code for deleting existing flags
Ark6.Activate 'Ark6 is Danish for Sheet6
ActiveSheet.Unprotect
For Each sh In ActiveSheet.Shapes
If sh.Type = msoPicture Then
sh.Delete
End If
Next
'Code for pasting new flags with birthdays
Range("L35").Select
For Each c In Range("D333, H3:H33, L3:L33, P3:P33, T3:T33, X3:X33, AB3:AB33, AF3:AF33, AJ3:AJ33, AN3:AN33, AR3:AR33, AV3:Av33")
CellValue = c.Value
If CellValue Like "*år.*" Then
c.Activate
ActiveSheet.Paste
Selection.ShapeRange.IncrementLeft 42
Selection.ShapeRange.IncrementTop -3
End If
Next
ActiveSheet.Protect
Ark1.Activate 'Ark1 is Danish for Sheet1
Range("L35").Select
Application.ScreenUpdating = True
End Sub[/vba]

[p45cal]

Sheet2 doesn't need to be unprotected to copy a picture from it.
No selecting or activating needs to take place at all. The code that follows leaves the selection and active sheet as they are, so I've taken all that out.
I haven't translated back to Danish.
It uses the .top and .left properties of the cell to position the picture.
You could also use the .height to make it fit exactly in the cell.
[vba]Sub SetFlag()
Application.ScreenUpdating = False
Sheet2.Shapes("Picture 1").Copy
For Each sht In Array(Sheet1, Sheet6)
With sht
.Unprotect
For Each sh In .Shapes
If sh.Type = msoPicture Then
sh.Delete
End If
Next sh
'Code for pasting new flags with birthdays
For Each c In .Range("D333, H3:H33, L3:L33, P3:P33, T3:T33, X3:X33, AB3:AB33, AF3:AF33, AJ3:AJ33, AN3:AN33, AR3:AR33, AV3:Av33")
If c.Value Like "*år.*" Then
.Paste
With .Shapes(.Shapes.Count)
.Top = c.Top
.Left = c.Left + c.Width - .Width
End With
End If
Next c
.Protect
End With
Next sht
Application.ScreenUpdating = True
End Sub
[/vba]

[perhol]

Sweet

Nearly half the number of codelines dooing more than before.

Testet good!

Thankyou p45cal