Копирование нескольких вариантов

Question

Я работаю над проектом, в котором мне нужно скопировать несколько странных фигур в определенный диапазон, чтобы выровнять верхние правые углы.Проблема в том, что копирование не работает на множественный выбор, и я не могу использовать один выбор.Мне нужна функция, которая с заданным диапазоном, состоящим из нескольких диапазонов (используя функцию объединения), скопирует его во второй диапазон, который является только одной ячейкой, поэтому верхний правый угол первого диапазона является вторым аргументом.Извините за грязное объяснение.Пример объяснит это лучше:

Set my_rng1 = Union(Range("A4:C4"), Range("C2:C3"))  
Set rngDestination = Range("M2")  
call Multiple_selection_copy(my_rng1, rngDestination)

Я бы получил: Результат

Конечно, мне нужна функция, чтобы быть динамической.

Answer 1

Необходимо только .Offset указанную ячейку назначения в соответствии с каждой исходной ячейкой во время копирования ячейки за ячейкой. Это работает, даже если верхние ячейки не выровнены.

Private Sub CopyMultiRange(ByRef src As Range, ByRef dest As Range)
    Dim c As Range
    Dim topcell As Range

    Set topcell = src(1)  ' find the top right cell of source range
    For Each c In src
        If c.Row < topcell.Row Then Set topcell = c
        If c.Column > topcell.Column And c.Row = topcell.Row Then Set topcell = c
    Next c

    For Each c In src ' assign each cell's value
        dest.Offset(c.Row - topcell.Row, c.Column - topcell.Column).Value = c.Value
    Next c
End Sub

Answer 2

Option Explicit

Sub CopyMultipleSelection()
Dim my_Rng1 As Range, rngDestination As Range
Set my_Rng1 = Union(Range("C2:C3"), Range("A4:C4"))
Set rngDestination = Range("M2")
'Set my_Rng1 = Union(Range("M2:M3"), Range("K4:M4"))
'Set rngDestination = Range("A2")
Call Multiple_selection_copy(my_Rng1, rngDestination)
End Sub

Sub Multiple_selection_copy(rngSource As Range, rngDestination As Range)
Dim rowOffset As Long, colOffset As Long
Dim actCellAtStart As Range
Dim actCell As Range
    Application.ScreenUpdating = False
    Set actCellAtStart = ActiveCell
    Debug.Print rngSource.Cells(1, 1).Address
    Debug.Print rngDestination.Cells(1, 1).Address
    colOffset = rngDestination.Cells(1, 1).Column - rngSource.Cells(1, 1).Column
    rowOffset = rngDestination.Cells(1, 1).Row - rngSource.Cells(1, 1).Row
    Debug.Print "rowOffset : "; rowOffset
    Debug.Print "colOffset : "; colOffset
    For Each actCell In rngSource.Cells
        On Error Resume Next
        Debug.Print actCell.Address; " --> "; actCell.Offset(rowOffset, colOffset).Address
        actCell.Copy
        actCell.Offset(rowOffset, colOffset).PasteSpecial xlPasteAll
        On Error GoTo 0
    Next actCell
    Application.CutCopyMode = False
    actCellAtStart.Select
    Application.ScreenUpdating = True
End Sub