ANmaCopy_Objects

Copies objects from cell into cell
Decide Sheet, and workbooks to copy from or to, like my other formulas as usual.
Uses Copy and Paste (clipboard) to move object. I do not like this, but this is until I find a way to copy objects without using clipboard.

Extracted from ConcaUFO_RowsfromSheets


Public

Not Tested

My Own Work
Function ANmaCopy_Objects(FromCell, ToCell, Optional FromSheet = "Active", Optional ToSheet = "Active", Optional FromWB = "This", Optional ToWB = "This")
    '
    ' Copies objects from cell into cell
    '        Objects are actually can be bound to cells behind them, we just need to find them and move them
    ' Uses Copy and Paste (clipboard) to move object
    '        I do not like this, but this is until I find a way to copy objects without using clipboard
    '
    If FromWB = "This" Then FromWB = Thisworkbook.Name
    If ToWB = "This" Then ToWB = Thisworkbook.Name
    If FromSheet = "Active" Then FromSheet = WOrkbooks(FromWB).ActiveSheet
    If ToSheet = "Active" Then ToSheet = WOrkbooks(ToWB).ActiveSheet
   
    Workbooks(ToWB).Activate '                                Important to copy objects
    Workbooks(ToWB).Worksheets(ToSheet).Activate '    Important to copy objects
   
    BoxesPerCell = 0 ' If we have multiple objects in FromCell, seperate them with spaces after moving into ToCell
   
    RowHeight = Workbooks(FromWB).Worksheets(FromSheet).Range(FromCell).Top '                                                            The top of that row to look for objects
    RowBottom = Workbooks(FromWB).Worksheets(FromSheet).Range(FromCell).Offset(1).Top '                                                The bottom of that row to look for objects between those boundaries
    ColLeft = Workbooks(FromWB).Worksheets(FromSheet).Range(FromCell).Left
    ColRight = Workbooks(FromWB).Worksheets(FromSheet).Range(FromCell).Offset(, 1).Left
    For Each Objj In Workbooks(FromWB).Worksheets(FromSheet).Shapes '                                                                        Loop through all objects in that sheet
        If Objj.Top >= RowHight And Objj.Top <= RowBottom And Objj.Left >= ColLeft And Objj.Left <= ColRight Then '            Is this object falls between top and bottom of that row?
            ' Workbooks(ToWB).Worksheets(ToSheet).Range(ToCell).Select
            ' Workbooks(ToWB).Worksheets(ToSheet).Range(ToCell).Value = Objj.Name '                                                            Bring object name to confirm that we do have an object here
           
            Objj.Copy '                        Copy object
            DoEvents
            Workbooks(ToWB).Worksheets(ToSheet).Paste '                                                                                            Paste it into this sheet
            Doevents
            Selection.Left = Workbooks(ToWB).Worksheets(ToSheet).Range(ToCell).Left + BoxesPerCell '                                Move it to ToCell
            Selection.Top = Workbooks(ToWB).Worksheets(ToSheet).Range(ToCell).Top
           
            BoxesPerCell = BoxesPerCell + 60
            Workbooks(ToWB).Worksheets(ToSheet).Range(ToCell).Select ' To remove selection
        End If
    Next
End Function

FromCell, ToCell, Optional FromSheet = "Active", Optional ToSheet = "Active", Optional FromWB = "This", Optional ToWB = "This"

Views 75 Downloads 23

VBA-Excel Graphics
ANmarAmdeen
763
Attachments
Revisions

v2.0