Option Explicit

'n行おきに選択するマクロ
Sub SelectRowsStepN()
    Const myTitle As String = "n行おきの選択"
    Dim oRange_Input As Range
    Dim oRange_Result As Range
    Dim sDefault As String
    Dim vRet As Variant
    Dim iRowCount1 As Long
    Dim iRowCount2 As Long
    Dim iStart As Long
    Dim iRowCount_Input As Long
    Dim iRowCount_Select As Long
    Dim iRowCount_Select2 As Long
    Dim iRow_Last As Long
    Dim iRow_Max As Long
    Dim iStep As Long

    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
            iRowCount_Input = oRange_Input.Rows.Count
            If iRowCount_Input > 1000 Then
                If MsgBox("範囲が大きいため長い時間がかかります。続行しますか?", _
                    vbExclamation Or vbOKCancel Or vbDefaultButton2, myTitle) _
                    = vbOK Then Exit Do
            Else
                Exit Do
            End If
        End If
    Loop

    '開始行の入力
    Do While True
        vRet = Application.InputBox( _
            prompt:="選択開始行を入力してください。範囲の先頭行を1とします。", _
            title:=myTitle, default:=1, Type:=1)
        If VarType(vRet) = vbBoolean Then Exit Sub
        iStart = CLng(vRet)
        If iStart < 1 Then
            MsgBox "1以上の整数を入力してください。", _
                vbExclamation, myTitle
        ElseIf iRowCount1 > iRowCount_Input Then
            MsgBox CStr(iRowCount_Input) & "以下の整数を入力してください。", _
                vbExclamation, myTitle
        Else
            Exit Do
        End If
    Loop

    iRowCount_Select = iRowCount_Input - iStart + 1

    '行数の入力
    Do While True
        vRet = Application.InputBox( _
            prompt:="選択する行数を入力してください。", _
            title:=myTitle, default:=1, Type:=1)
        If VarType(vRet) = vbBoolean Then Exit Sub
        iRowCount1 = CLng(vRet)
        If iRowCount1 < 1 Then
            MsgBox "1以上の整数を入力してください。", _
                vbExclamation, myTitle
        ElseIf iRowCount1 > iRowCount_Select Then
            MsgBox CStr(iRowCount_Select) & "以下の整数を入力してください。", _
                vbExclamation, myTitle
        Else
            Exit Do
        End If
    Loop

    '行間隔の入力
    Do While True
        vRet = Application.InputBox( _
            prompt:="間隔の行数を入力してください。", _
            title:=myTitle, default:=1, Type:=1)
        If VarType(vRet) = vbBoolean Then Exit Sub
        iRowCount2 = CLng(vRet)
        If iRowCount2 < 1 Then
            MsgBox "1以上の整数を入力してください。", _
                vbExclamation, myTitle
        Else
            Exit Do
        End If
    Loop

    iRow_Max = oRange_Input.Worksheet.Rows.Count
    iStep = iRowCount1 + iRowCount2

    '選択範囲の行数を計算
    iRowCount_Select2 = _
        ((iRowCount_Select - 1) \ iStep + 1) * iStep - iRowCount2

    '選択範囲の最終行番号を計算
    iRow_Last = oRange_Input.Rows(1).Row + iStart - 2 + iRowCount_Select2

    '対象範囲を調整
    If iRow_Last > iRow_Max Then
        Set oRange_Input = oRange_Input.Resize(iRowCount_Select2 - iStep)
    End If

    Set oRange_Result = GetRowsStepN( _
        oRange_Input, iStart, iRowCount1, iRowCount2)

    With oRange_Result.Areas(1)
        .Worksheet.Parent.Activate
        .Worksheet.Activate
    End With
    oRange_Result.Select
    Exit Sub

ErrorHandler:
    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


'n行おきの範囲を取得する関数(引数チェックなし)

'oRange_Target: 対象範囲
'iStart       : 開始行
'iRowCount1   : 選択行数
'iRowCount2   : 間隔行数

Function GetRowsStepN(oRange_Target As Range, iStart As Long, _
        iRowCount1 As Long, iRowCount2 As Long) As Range
    Dim oRange_Result As Range
    Dim iRowCount_Target As Long
    Dim iRowCount_Range As Long
    Dim iStep As Long
    Dim iStatus As Integer
    Dim iOldStatus As Integer
    Dim i As Long

    Application.OnTime Now, "ResetStatusBar"
    iRowCount_Target = oRange_Target.Rows.Count
    iRowCount_Range = iRowCount_Target - iStart + 1
    iOldStatus = -1

    'ステップ数を計算
    iStep = iRowCount2 + iRowCount1

    '最初の行を取得し、結果の範囲に設定
    Set oRange_Result = oRange_Target.Rows(iStart).Resize(iRowCount1)

    '次の行から最終行まで、指定間隔で繰り返す
    For i = iStart + iStep To iRowCount_Target Step iStep

        '結果の範囲に行を追加
        Set oRange_Result = Application.Union(oRange_Result, _
            oRange_Target.Rows(i).Resize(iRowCount1))

        iStatus = (i - iStart) * 10 \ iRowCount_Range
        If iStatus <> iOldStatus Then
            MyStatusBar iStatus
            iOldStatus = iStatus
        End If

    Next

    '結果の範囲を戻り値に設定
    Set GetRowsStepN = oRange_Result

End Function


Sub MyStatusBar(ByVal Value As Integer)
    If Value < 0 Then Value = 0
    If Value > 10 Then Value = 10
    Application.StatusBar = "処理中です... " _
        & Right$("  " & CStr(Value * 10), 3) & "% " & _
        String$(Value, Chr$(&h81a1)) & String$(10 - Value, Chr$(&h81a0))
End Sub


Sub ResetStatusBar()
    Application.StatusBar = False
End Sub