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
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
'
' 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 876
Downloads 349
CodeID
DB ID