☰

如何排除范围内的范围重叠？（移动单元格内容宏）

tag-icon • tag-icon microsoft-excel macros
如何排除范围内的范围重叠？（移动单元格内容宏）

我无法找到在不改变格式的情况下移动单元格内容的宏。

我在下面编写了一个宏来实现这一点，但它会清除与复制范围重叠的粘贴范围。有人能帮忙编写代码以排除重叠部分被清除吗？

在此处输入图片描述

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 范围中定义一个新范围，但不知道如何做。

答案1

您将删除整个原始范围。如果重叠，它也会删除重叠的单元格。为了避免这种情况，请检查每个单元格以查看是否有重叠，例如，您可以将其替换Range(COPYSOURCE).ClearContents为

    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

相关内容