'重複のないデータを作成するマクロ

Option Explicit

Sub UniqueDataCopy()
    Const myTitle As String = "重複のないデータの作成"
    Dim oRange_Input As Range, oRange_Output As Range
    Dim sDefault As String

    On Error GoTo err_1

    If TypeName(Selection) = "Range" Then
        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
        ElseIf oRange_Input.Cells.Count = 1 Then
            MsgBox "1つ以上のデータが必要です。", 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

    oRange_Output.Cells(1, 1).ClearContents
    oRange_Input.AdvancedFilter Action:=xlFilterCopy, CopyToRange:=oRange_Output, Unique:=True

    Exit Sub

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

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