Mac – How to exclude ranges overlap from a range ? (Move cell contents macro)

macrosmicrosoft excel

I have been unable to find a macro to move cell contents without changing formatting.

I put together a macro below which achieves this, BUT it clears the pasted range where it overlaps the copied range. Can anyone help with the code to exclude the overlapped part from being cleared?

enter image description here

Sub E____MoveContentsOnlyKeepFormats_SIMPLE_Ctrl_M()

Application.CutCopyMode = False 'clears any existing copy mode
On Error GoTo EXITSUB 'exits if cancel clicked (NB cant use label "end")

    Dim RANGE_TO_COPY As Range 'define inputbox variable
    Dim CELL_TO_PASTE_TO As Range 'define inputbox variable

'-----------name SOURCE range = selected before macro started
    Set RANGE_TO_COPY = Selection 'is this necessary, when not using inputbox?
        COPYSOURCE = RANGE_TO_COPY.Address(False, False) 'name the inputbox selection as a range

'=========== inputbox to select PASTE destination
    Set CELL_TO_PASTE_TO = Application.InputBox("select cell/range to PASTE TO, with the mouse" & vbNewLine & "CANCEL IF RANGES OVERLAP!", Default:=Selection.Address, Type:=8)

'------------- assigns name to the selected DESTINATION range
    PASTERANGE = CELL_TO_PASTE_TO.Address(False, False) 'name the inputbox selection as a range

'=========== action = COPY SOURCE
    Range(COPYSOURCE).Copy

'======================PASTE TO DESTINATION
'DEFAULT: PASTE FORMULAS AND NUMBER FORMATS (MATCHES DESTINATION FORMAT, keeps date/ etc original):

    Range(PASTERANGE) _
    .PasteSpecial Paste:=xlPasteFormulasAndNumberFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False 'formulas+number format

'======DELETE SOURCE CELL CONTENTS - remove if COPY required

'??? how to select COPYSOURCE not overlapping PASTERANGE

        Range(COPYSOURCE).ClearContents 'deletes contents keeps formatting

EXITSUB:

End Sub

Thanks (I am a newbie, any help appreciated)

EDIT: I was looking to define a new range from the COPYSOURCE range by excluding the intersected part using intersect or not intersect arguments, couldn't figure how.

Best Answer

You delete your whole original range. If it overlaps, it will delete overlapping cells too. To avoid that, check each cell to see if there's an overlap, e.g you can replace Range(COPYSOURCE).ClearContents by

    Dim rgLoop As Range, rgToDelete As Range
        For Each rgLoop In Range(copysource).Cells
            If Intersect(rgLoop, Range(pasterange).Resize(Range(copysource).Rows.Count, Range(copysource).Columns.Count)) Is Nothing Then
                If rgToDelete Is Nothing Then Set rgToDelete = rgLoop Else Set rgToDelete = Union(rgToDelete, rgLoop)
            End If
        Next rgLoop

        rgToDelete.ClearContents 'deletes contents keeps formatting
Related Question