VBA复制非连续选择区域

Excel中你是无法多重选定区域进行复制的，于是水文工具集介绍一个采用VBA宏过程突破这一限制来完成对非连续选择区域的复制粘贴，具体VBA实现代码如下：

'================================
' VBA复制非连续选择区域
'
' 
'================================
Sub HUP_CopyMultipleSelection()
    Dim SelAreas() As Range
    Dim PasteRange As Range
    Dim UpperLeft As Range
    Dim NumAreas As Long, i As Long
    Dim TopRow As Long, LeftCol As Long
    Dim RowOffset As Long, ColOffset As Long

    If TypeName(Selection) <> "Range" Then Exit Sub

'   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:="指定粘贴目标左上角单元格:", _
      Title:="Copy Multiple Selection www.CnHUP.com", _
      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")

'   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