复制多个选择

Question

我正在一个项目中，我需要将一些奇怪的形状复制到特定范围，以便右上角对齐。问题是应对不适用于多项选择，而我不能使用一项选择。我需要一个函数，该函数将由多个范围组成的给定范围（使用并集函数）将其复制到仅一个单元格的第二个范围，因此第一个范围的右上角是第二个参数。很抱歉造成您的解释混乱。该示例将对其进行更好的解释：

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

我会得到： Result

当然，我需要功能是动态的。

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 。即使顶部单元格未对齐，此方法也有效。

{{1}}

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