Option Explicit

'選択範囲の定数セルをコピーするマクロ
Sub CopySpecialCells_Constants_Selection()
    Const myTitle As String = "定数セルのコピー"
    Dim oRange_Input As Range
    Dim oRange_Output As Range
    Dim sDefault As String

    On Error GoTo ErrorHandler

    If TypeName(Selection) = "Range" Then
        With Selection
            If .Cells.Count = 1 Then .CurrentRegion.Select
        End With
        sDefault = Selection.Address
    Else
        sDefault = ""
    End If

    'コピー範囲の選択
    Do While True
        Set oRange_Input = InputBoxRange( _
            "コピーする範囲を選択してください。", myTitle, sDefault)
        If oRange_Input Is Nothing Then Exit Sub
        If oRange_Input.Areas.Count <> 1 Then
            MsgBox "連続していない範囲に対しては実行できません。", _
                vbExclamation, myTitle
        Else
            Exit Do
        End If
    Loop

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

    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

    '定数セルのコピー
    CopySpecialCells_Constants oRange_Input, oRange_Output

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


'定数セルをコピーするマクロ
Sub CopySpecialCells_Constants( _
        oRange_Input As Range, oRange_Output As Range)

    Const myTitle As String = "定数セルのコピー"
    Dim oRange_Target As Range
    Dim iErr As Long
    Dim sErr As String
    Dim iRet As Long

    '対象範囲が単一セルの場合の処理
    '（確実に2つ以上のセルを対象にする場合は不要です。）
    If (oRange_Input.Areas.Count = 1) And _
            (oRange_Input.Cells.Count = 1) Then
        If IsEmpty(oRange_Input.Value) Or _
                (oRange_Input.HasFormula) Then
            MsgBox "定数のセルがありません。", vbExclamation, myTitle
        Else
            iRet = CopyAreas_Values(oRange_Input, oRange_Input, oRange_Output)
            If iRet <> 0 Then
                MsgBox "コピー処理でエラーが発生しました。", vbExclamation, myTitle
            End If
        End If
        Exit Sub
    End If

    '定数のセルを取得
    On Error Resume Next
    Set oRange_Target = oRange_Input.SpecialCells(xlConstants)
    iErr = Err
    sErr = Error(iErr)
    On Error GoTo 0

    Select Case iErr
        Case 0
        Case Else
            MsgBox sErr & " (" & CStr(iErr) & ")", vbExclamation, myTitle
            Exit Sub
    End Select

    Application.ScreenUpdating = False

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

    Application.ScreenUpdating = True

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