Como excluir intervalos sobrepostos de um intervalo? (Mover a macro do conteúdo da célula)

Question

Não consegui encontrar uma macro para mover o conteúdo da célula sem alterar a formatação.

Eu reuni uma macro abaixo da qual alcança isso, MAS limpa o intervalo colado onde ele se sobrepõe ao intervalo copiado. Alguém pode ajudar com o código para excluir a parte sobreposta de ser apagada?

SubE____MoveContentsOnlyKeepFormats_SIMPLE_Ctrl_M()Application.CutCopyMode=False'clearsanyexistingcopymodeOnErrorGoToEXITSUB'exitsifcancelclicked(NBcantuselabel"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

Obrigado (eu sou um novato, qualquer ajuda apreciada)

EDIT: Eu estava olhando para definir um novo intervalo a partir do intervalo COPYSOURCE, excluindo a parte cruzada usando intersect ou não cruzar argumentos, não poderia descobrir como.

    

Answer 1

Você exclui todo o seu intervalo original. Se sobrepuser, também excluirá as células sobrepostas. Para evitar isso, verifique cada célula para ver se há uma sobreposição, por exemplo, você pode substituir Range(COPYSOURCE).ClearContents por

    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