The is no cell with a button in it. There are some cells with a button over them.
I think this routine will do what you want, once the Source and destination ranges are set to match your situation. The positioning of the button may be a bit odd if the height and width of the source cells and destination cells is different.
Sub test()
Dim sourceRange As Range, sourceCell As Range
Dim destinationRange As Range
Dim rNum As Long, cNum As Long
Dim Loffset As Single, Toffset As Single
Dim coveringButton As Shape
Set sourceRange = Sheet1.Range("B3:C5"): Rem adjust
Set destinationRange = Sheet1.Range("P10"): Rem adjust
With sourceRange
Rem copy buttons
For rNum = 1 To .Rows.Count
For cNum = 1 To .Columns.Count
With .Cells(rNum, cNum)
Set coveringButton = ButtonCovering(.Cells)
If coveringButton Is Nothing Then
Rem do nothing
Else
Loffset = coveringButton.Left - .Left
Toffset = coveringButton.Top - .Top
coveringButton.Copy
With destinationRange.Parent
.Paste
With .Shapes(.Shapes.Count)
.Top = destinationRange(rNum, cNum).Top + Toffset
.Left = destinationRange.Cells(rNum, cNum).Left + Loffset
End With
End With
End If
End With
Next cNum
Next rNum
Rem copy cells
.Copy Destination:=destinationRange
End With
End Sub
Function ButtonCovering(aCell As Range) As Shape
Dim oneShape As Shape
For Each oneShape In aCell.Parent.Shapes
With oneShape
If .Type = msoFormControl Then
If .FormControlType = xlButtonControl Then
If ((aCell.Left < .Left + .Width / 2) And (.Left + .Width / 2 <= aCell.Left + aCell.Width)) _
And ((aCell.Top < .Top + .Height / 2) And (.Top + .Height / 2 < aCell.Top + aCell.Height)) Then
Set ButtonCovering = oneShape
Exit Function
End If
End If
End If
End With
Next oneShape
End Function
Bookmarks