Consulting

Results 1 to 3 of 3

Thread: Solved: Put picture in top right corner of cell

  1. #1

    Solved: Put picture in top right corner of cell

    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]
    Last edited by perhol; 01-13-2010 at 09:20 AM.

  2. #2
    Knowledge Base Approver VBAX Wizard
    Joined
    Oct 2005
    Location
    Surrey UK
    Posts
    5,039
    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]
    p45cal - - - - -This is my signature, it appears after all my posts. Below is not directed at anyone in particular - so don't take offence! - (You might guess why it's there though)
    If I've helped and you can't be bothered to acknowledge it, I can't be bothered to look at further posts from you.

  3. #3
    Sweet

    Nearly half the number of codelines dooing more than before.

    Testet good!

    Thankyou p45cal


Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •