Option Explicit

'選択された複数セル範囲をコピーするマクロ
Sub CopyAreas_Values_Selection()
    Const myTitle As String = "複数セル範囲のコピー"
    Dim oRange_Input As Range
    Dim oRange_Target As Range
    Dim oRange_Output As Range
    Dim iRet As Long

    On Error GoTo ErrorHandler

    'コピー範囲の取得
    If TypeName(Selection) = "Range" Then
        Set oRange_Target = Selection
    Else
        MsgBox "セルを選択して実行してください。", _
            vbExclamation, myTitle
        Exit Sub
    End If

    '貼り付け先範囲の選択
    Set oRange_Output = InputBoxRange( _
        "貼り付け先のセルを選択してください。", myTitle, "")
    If oRange_Output Is Nothing Then Exit Sub
    Set oRange_Output = oRange_Output.Cells(1, 1)

    Set oRange_Input = UnionAreas(oRange_Target)

    If Application.CountA(oRange_Output.Resize( _
            oRange_Input.Rows.Count, oRange_Input.Columns.Count)) <> 0 Then
        If MsgBox("出力範囲にはデータがあります。上書きしますか？", _
                vbYesNo Or vbExclamation, myTitle) <> vbYes Then
            Exit Sub
        End If
    End If

    Application.ScreenUpdating = False

    '複数セル範囲のコピー
    iRet = CopyAreas_Values(oRange_Input, oRange_Target, oRange_Output)

    Application.ScreenUpdating = True

    If iRet <> 0 Then
        MsgBox "コピー処理でエラーが発生しました。", vbExclamation, myTitle
    End If

    Exit Sub
ErrorHandler:
    MsgBox Error(Err) & " (" & Err & ")", vbExclamation, myTitle
End Sub


'複数セル範囲をコピーするマクロ

'oRange_Input:  コピー元の基準位置のセル
'oRange_Target: コピー範囲
'oRange_Output: 貼り付け先の基準位置のセル

Function CopyAreas_Values(ByVal oRange_Input As Range, _
        ByVal oRange_Target As Range, _
        ByVal oRange_Output As Range) As Long
    Dim oSheet_Output As Worksheet
    Dim iRow_Offset As Long
    Dim iColumn_Offset As Long
    Dim r As Range

    On Error GoTo ErrorHandler

    '貼り付け先ワークシートの取得
    Set oSheet_Output = oRange_Output.Worksheet

    '貼り付け先セル位置のオフセットを取得
    Set oRange_Input = oRange_Input.Cells(1, 1)
    Set oRange_Output = oRange_Output.Cells(1, 1)
    iRow_Offset = oRange_Output.Row - oRange_Input.Row
    iColumn_Offset = oRange_Output.Column - oRange_Input.Column

    'セル範囲単位に値のみをコピー
    For Each r In oRange_Target.Areas
        r.Copy
        oSheet_Output.Cells(r.Row + iRow_Offset, _
            r.Column + iColumn_Offset).PasteSpecial xlValues
    Next

    'コピーモードの解除
    Application.CutCopyMode = False

    CopyAreas_Values = 0
    Exit Function
ErrorHandler:
    CopyAreas_Values = 1
    Exit Function
End Function


'セル範囲を入力する関数
Function InputBoxRange(prompt As String, title As String, _
        default As String) As Range
    On Error Resume Next
    Set InputBoxRange = Application.InputBox( _
        prompt:=prompt, title:=title, default:=default, Type:=8)
End Function


'複数セル範囲を1つの範囲にする関数
Function UnionAreas(oRange_Input As Range) As Range
    Const MAXLONG As Long = &h7fffffff
    Dim iLeft As Long, iTop As Long, iRight As Long, iBottom As Long
    Dim iLeft2 As Long, iTop2 As Long, iRight2 As Long, iBottom2 As Long
    Dim r As Range

    iLeft = MAXLONG
    iTop = MAXLONG
    iRight = 0
    iBottom = 0

    For Each r In oRange_Input.Areas
        iLeft2 = r.Column
        iTop2 = r.Row
        iRight2 = iLeft2 + r.Columns.Count
        iBottom2 = iTop2 + r.Rows.Count
        If iLeft2 < iLeft Then iLeft = iLeft2
        If iTop2 < iTop Then iTop = iTop2
        If iRight2 > iRight Then iRight = iRight2
        If iBottom2 > iBottom Then iBottom = iBottom2
    Next

    Set UnionAreas = oRange_Input.Worksheet.Cells(iTop, iLeft) _
        .Resize(iBottom - iTop, iRight - iLeft)

End Function