是否存在某个脚本或修改 Excel 的方法，以允许复制和粘贴多个选定区域？

Question

这样做的原因是，在 excel 中，复制一段单元格后，您只能突出显示更多单元格，而不能从选择中减去。这让我很恼火，所以今天我编写了一个 vba 脚本来从选择中减去多次突出显示的单元格。

Sub MultiDeselect()
Dim rng As Range
Dim Uni As Range 'this is the union
Dim Intersct As Range
Dim UnionMinusIntersect As Range
Dim singleArea As Range

'MsgBox ActiveCell.Address
If Selection.Areas.Count > 1 Then
    For Each singleArea In Selection.Areas
        For Each rng In singleArea.Cells
            If Uni Is Nothing Then
                Set Uni = rng
            ElseIf Application.Intersect(Uni, rng) Is Nothing Then
                Set Uni = Union(Uni, rng)
            ElseIf Intersct Is Nothing Then
                Set Intersct = rng
            ElseIf Intersect(Intersct, rng) Is Nothing Then
                Set Intersct = Union(Intersct, rng)
            End If
        Next rng
    Next singleArea
'    MsgBox Uni.Address
    If Intersct Is Nothing Then
        Set UnionMinusIntersect = Uni
    Else
'        MsgBox Intersct.Address
        For Each singleArea In Uni
            For Each rng In singleArea.Cells
'                MsgBox rng.Address
                If Intersect(rng, Intersct) Is Nothing Then
                    If UnionMinusIntersect Is Nothing Then
                        Set UnionMinusIntersect = rng
                    Else
                        Set UnionMinusIntersect = Union(UnionMinusIntersect, rng)
                    End If
                End If
            Next rng
        Next singleArea
    End If
    'Check not null in case every cell was highlighted more than once
    If Not UnionMinusIntersect Is Nothing Then
        If UnionMinusIntersect.Cells.Count > 0 Then
            UnionMinusIntersect.Select
        End If
    End If
End If
End Sub

令我沮丧的是，完成后，我发现 excel 中不允许复制多个区域，这违背了我通常突出显示某些内容的目的。在我尝试实现多次复制和多次粘贴之前，我想知道是否有人已经这样做了。它基本上会将相对于选择左上角的每个单元格复制到相对于活动单元格左上角的相应单元格中。

---

Jordan 的答案非常有效。以下是最终输出的示例：

Answer 1

两个简单的 VB 宏。

1. 创建新的启用宏的工作簿
2. 创建下面的两个宏。
3. 创建向某些单元格添加一些值
4. 跑步取消选择单元格宏
   • 首先选择要提供的整个范围，如果您使用Excel 表示例从下面，您可以输入：$A$1:$F$6然后按确定。
   • 现在您需要指定要选择的单元格，只需单击鼠标左键即可指定范围。（按住 Ctrl 并单击鼠标左键可取消选择多个范围。例如，输入：$A$1,$C$2,$C$6然后按确定。
5. 此时你应该有一个取消选择活动区域就像上面的图片一样。现在只需运行复制多项选择宏并指定要将结果粘贴到哪个单元格中。在我们的例子中，假设$A$9您最终复制的表格将如下所示：

最终粘贴表：（您将有一个空单元格而不是 _，这仅适用于这里，因为格式问题。

_   4   1   2   3   4
d   a   _   6   7   8
f   9   11  1   1   121
a   21  1   12  12  sa
b   a   a   sd  a   sa
324 234 _   23  423 42

Excel 表示例：左上角是单元格 A1，右下角是单元格 F6

1   4   1   2   3   4
d   a   5   6   7   8
f   9   11  1   1   121
a   21  1   12  12  sa
b   a   a   sd  a   sa
324 234 234 23  423 42

宏

Sub DeselectCell()
    Dim rng As Range
    Dim InputRng As Range
    Dim DeleteRng As Range
    Dim OutRng As Range
    xTitleId = "DeselectCell"
    Set InputRng = Application.Selection
    Set InputRng = Application.InputBox("Range :", xTitleId, InputRng.Address, Type:=8)
    Set DeleteRng = Application.InputBox("Delete Range", xTitleId, Type:=8)
    For Each rng In InputRng
        If Application.Intersect(rng, DeleteRng) Is Nothing Then
            If OutRng Is Nothing Then
                Set OutRng = rng
            Else
                Set OutRng = Application.Union(OutRng, rng)
            End If
        End If
    Next
    OutRng.Select
End Sub

Sub CopyMultipleSelection()
    Dim SelAreas() As Range
    Dim PasteRange As Range
    Dim UpperLeft As Range
    Dim NumAreas As Integer, i As Integer
    Dim TopRow As Long, LeftCol As Integer
    Dim RowOffset As Long, ColOffset As Integer
    Dim NonEmptyCellCount As Integer
' Exit if a range is not selected
    If TypeName(Selection) <> "Range" Then
        MsgBox "Select the range to be copied. A multiple selection is allowed."
        Exit Sub
    End If
' Store the areas as separate Range objects
    NumAreas = Selection.Areas.Count
    ReDim SelAreas(1 To NumAreas)
    For i = 1 To NumAreas
        Set SelAreas(i) = Selection.Areas(i)
    Next
' Determine the upper left cell in the multiple selection
    TopRow = ActiveSheet.Rows.Count
    LeftCol = ActiveSheet.Columns.Count
    For i = 1 To NumAreas
        If SelAreas(i).Row < TopRow Then TopRow = SelAreas(i).Row
        If SelAreas(i).Column < LeftCol Then LeftCol = SelAreas(i).Column
    Next
    Set UpperLeft = Cells(TopRow, LeftCol)
' Get the paste address
    On Error Resume Next
    Set PasteRange = Application.InputBox _
    (Prompt:="Specify the upper left cell for the paste range:", _
    Title:="Copy Mutliple Selection", _
    Type:=8)
    On Error GoTo 0
' Exit if canceled
    If TypeName(PasteRange) <> "Range" Then Exit Sub
' Make sure only the upper left cell is used
    Set PasteRange = PasteRange.Range("A1")
' Check paste range for existing data
    NonEmptyCellCount = 0
    For i = 1 To NumAreas
        RowOffset = SelAreas(i).Row - TopRow
        ColOffset = SelAreas(i).Column - LeftCol
        NonEmptyCellCount = NonEmptyCellCount + _
        Application.CountA(Range(PasteRange.Offset(RowOffset, ColOffset), _
        PasteRange.Offset(RowOffset + SelAreas(i).Rows.Count - 1, _
        ColOffset + SelAreas(i).Columns.Count - 1)))
  Next i
' If paste range is not empty, warn user
  If NonEmptyCellCount <> 0 Then _
        If MsgBox("Overwrite existing data?", vbQuestion + vbYesNo, _
        "Copy Multiple Selection") <> vbYes Then Exit Sub
' Copy and paste each area
  For i = 1 To NumAreas
    RowOffset = SelAreas(i).Row - TopRow
    ColOffset = SelAreas(i).Column - LeftCol
    SelAreas(i).Copy PasteRange.Offset(RowOffset, ColOffset)
  Next i
End Sub