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

400
Piecevcake

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

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

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

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

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

0

1 ответ на вопрос

2
nutsch

Вы удаляете весь свой оригинальный диапазон. Если он перекрывается, он также удаляет перекрывающиеся ячейки. Чтобы избежать этого, проверьте каждую ячейку, чтобы увидеть, есть ли совпадение, например, вы можете заменить 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
Спасибо за это! Я подумал, может быть, есть способ определить новый диапазон, как COPYSOURCE минус пересекаются с PASTERANGE? Я попробовал несколько способов использовать, если не пересекаются, и т. Д., Но не мог понять это. Я не знаю, будет ли это быстрее? Piecevcake 6 лет назад 0
если ваши файлы не имеют больших сложных формул, вы не заметите никакой разницы nutsch 6 лет назад 0

Похожие вопросы