Copy multiple selections in excel 2003

[John Musbach]

In Excel you can make multiple selections in a spreadsheet by holding down "ctrl" while making selections, however normally Excel does not allow you to then copy these selections all at once and paste them elsewhere. I found a tip that suggests that this may in fact be possible using VBA (http://www.j-walk.com/ss/<wbr>excel/tips<wbr>/tip36.htm<wbr>) however the tip is quite old and it does not seem to properly work in Excel 2003. In my testing, it would not copy the entirety of the first selection--instead copying and pasting just the very bottom right cell--but it would properly copy and paste the rest of the selections in their entirety (with it handling a total of 5 selections). Admittedly I did make some modifications to the code to suite my own needs and as such I have attached the modified code to this post. Did I break the code and if so how or is this approach just not compatible with Excel 2003 and if so are there other ways of accomplishing this? Thanks!

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 Selection.Areas.Count <= 1 Then
        MsgBox "Holding down ctrl, please highlight the ranges for the population, households, retail jobs, total jobs, and employed residents selection before using this macro."
        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
'    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
        If i = 1 Then
        Sheets.Add.Name = "Population"
        SelAreas(i).Copy
        Sheets("Population").Range("A1").PasteSpecial xlPasteValues
        End If
        If i = 2 Then
        Sheets.Add.Name = "Households"
        SelAreas(i).Copy
        Sheets("Households").Range("A1").PasteSpecial xlPasteValues
        End If
        If i = 3 Then
        Sheets.Add.Name = "Retail Jobs"
        SelAreas(i).Copy
        Sheets("Retail Jobs").Range("A1").PasteSpecial xlPasteValues
        End If
        If i = 4 Then
        Sheets.Add.Name = "Total Jobs"
        SelAreas(i).Copy
        Sheets("Total Jobs").Range("A1").PasteSpecial xlPasteValues
        End If
        If i = 5 Then
        Sheets.Add.Name = "Employed Residents"
        SelAreas(i).Copy
        Sheets("Employed Residents").Range("A1").PasteSpecial xlPasteValues
        End If
        'If i > 5 Then
        'MsgBox ("ERROR: Too many selections!")
        'Exit Sub
        'End If
        'SelAreas(i).Copy 'PasteRange.Offset(RowOffset, ColOffset)
    Next i
End Sub</pre>