![如何排除范围内的范围重叠?(移动单元格内容宏)](https://linux22.com/image/1571989/%E5%A6%82%E4%BD%95%E6%8E%92%E9%99%A4%E8%8C%83%E5%9B%B4%E5%86%85%E7%9A%84%E8%8C%83%E5%9B%B4%E9%87%8D%E5%8F%A0%EF%BC%9F%EF%BC%88%E7%A7%BB%E5%8A%A8%E5%8D%95%E5%85%83%E6%A0%BC%E5%86%85%E5%AE%B9%E5%AE%8F%EF%BC%89.png)
我无法找到在不改变格式的情况下移动单元格内容的宏。
我在下面编写了一个宏来实现这一点,但它会清除与复制范围重叠的粘贴范围。有人能帮忙编写代码以排除重叠部分被清除吗?
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