perhol
01-13-2010, 09:00 AM
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:
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("D3:D33, 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("D3:D33, 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
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:
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("D3:D33, 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("D3:D33, 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