Есть ли где-нибудь сценарий или способ изменить 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, что противоречит моей обычной цели выделения чего-либо. Прежде чем я попытался реализовать мультикопирование и мультипасту, я хотел узнать, сделал ли это кто-то уже. В основном это будет копировать каждую ячейку относительно верхнего левого края выделения в соответствующую ячейку относительно верхнего левого угла активной ячейки.

---

Ответ Джордана прекрасно работает. Вот пример окончательного вывода:

Answer 1

Два простых макроса VB.

1. Создать новую книгу с поддержкой макросов
2. Создайте два макроса ниже.
3. Создать добавить некоторые значения в некоторые ячейки
4. Запустить макрос DeselectCell
   • Сначала выберите весь диапазон, который вы хотите указать. Если вы используете образец таблицы Excel из приведенного ниже списка, введите: $A$1:$F$6 и нажмите ОК.
   • Теперь вам нужно указать, какие ячейки вы хотите выбрать, просто щелкните левой кнопкой мыши, чтобы указать диапазон. (Удерживайте Ctrl и щелкните левой кнопкой мыши, чтобы отменить выбор нескольких диапазонов. Например, введите: $A$1,$C$2,$C$6 и нажмите ОК.
5. На этом этапе вы должны отменить выбор активной области, как на изображении выше. Теперь просто запустите макрос CopyMultipleSelection и укажите, в какую ячейку вы хотите вставить результаты. В нашем случае, скажем, $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