Как исключить перекрытие диапазонов из диапазона? (Переместить макрос содержимого ячейки)

Question

Мне не удалось найти макрос для перемещения содержимого ячейки без изменения форматирования.

Я собрал макрос ниже, который достигает этого, НО он очищает вставленный диапазон, где он перекрывает скопированный диапазон. Может ли кто-нибудь помочь с кодом, чтобы исключить перекрытие части от очистки?

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

Спасибо (я новичок, любая помощь приветствуется)

РЕДАКТИРОВАТЬ: я искал, чтобы определить новый диапазон из диапазона COPYSOURCE путем исключения пересеченной части, используя аргументы пересечения или не пересекаются, не мог понять, как.

Answer 1

Вы удаляете весь свой оригинальный диапазон. Если он перекрывается, он также удаляет перекрывающиеся ячейки. Чтобы избежать этого, проверьте каждую ячейку, чтобы увидеть, нет ли совпадений, например, вы можете заменить 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