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:
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