Excel Developer Tip

Excel page

Tip archives

Copying a Multiple Selection

Excel lets you make a multiple range selection, which is a group of non-contiguous cells. You do this by pressing Ctrl while you select the ranges with the mouse (you can also do this by using Shift+F8). However, you may have noticed that Excel does not let you copy a multiple selection. Attempting to do so brings up an error message: That command cannot be used on multiple selections.

When you encounter a limitation in Excel, you can often circumvent it by creating a macro. In this document I present a VBA subroutine that allows you to copy a multiple selection to another location. This subroutine works with Excel 5, Excel 95, and Excel 97.

The code is listed below. If you prefer, you can download the XLS file that contains the code.

To use this subroutine:

1. Copy the code to a VBA module. You can also store it in your Personal Macro Workbook, or create an add-in.
2. Select the cells that you want to copy.
3. Execute the CopyMultipleSelection subroutine. You will be prompted for the upper left cell of the destination range.
4. Specify the destination cell and click OK. If any data will be overwritten, you will be given a chance to cancel.

NOTE: This operation cannot be undone.

The CopyMultipleSelection Subroutine

Option Explicit

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