'InputBoxでワークシートにデータ入力するマクロ

'1行目が項目見出しであるシートをアクティブにして
'MyInputData2()を実行してください。


'  Sheet1
'     |   A    |   B    |   C    |
'  ---+--------+--------+--------+
'   1 | Field1 | Field2 | Field3 |
'   2 |        |        |        |
'   3 |        |        |        |

Option Explicit

Sub MyInputData2()
    Dim fieldData() As Variant
    Dim fieldName() As String
    Dim inputType() As Integer
    Dim fieldNo As Integer
    Dim ifCheckOK As Boolean
    Dim s1 As String, s2 As String
    Dim ret As Variant
    Dim i As Integer

    Application.Goto Sheets("Sheet1").Range("A1:C1")

    If Selection.Cells(1, 1).Value = "" Then
        MsgBox "項目見出しがありません。", vbExclamation, "データ入力"
        Exit Sub
    End If

    ReDim fieldData(1 To Selection.Columns.Count)
    ReDim fieldName(1 To Selection.Columns.Count)
    For i = 1 To UBound(fieldName)
        fieldName(i) = Selection.Cells(1, i).Value
    Next
    ReDim inputType(1 To Selection.Columns.Count)
    For i = 1 To UBound(inputType)
        inputType(i) = 1
    Next

    ActiveCell.Select
    If Selection.Offset(1).Value = "" Then
        Selection.Offset(1).Select
    Else
        Selection.End(xlDown).Offset(1).Select
    End If

    fieldNo = 1
    Do While True

        'プロンプト文字列作成
        s1 = ""
        For i = 1 To UBound(fieldData)
            If i = fieldNo Then
                s1 = s1 & "       >>" & Chr$(9) & _
                    fieldName(i) & ": " & fieldData(i) & Chr$(10)
            Else
                s1 = s1 & Chr$(9) & _
                    fieldName(i) & ": " & fieldData(i) & Chr$(10)
            End If
            s1 = Left$(s1, Len(s1))
        Next
        s2 = "データ入力 - " & fieldName(fieldNo)

        'データ入力
        ret = Application.InputBox(prompt:=s1, Title:=s2, _
            Type:=inputType(fieldNo))
        If VarType(ret) = vbBoolean Then
            If fieldNo = 1 Then
                Exit Do
            Else
                fieldData(fieldNo) = Empty
                fieldNo = fieldNo - 1
            End If
        Else

            'チェック処理
            ifCheckOK = True
            Select Case fieldNo
                Case 1 To UBound(fieldData)
                    If ret <= 0 Then
                        MsgBox "0より大きい整数値を入力してください。", _
                            vbExclamation, s2
                        ifCheckOK = False
                    End If
            End Select

            If ifCheckOK Then
                fieldData(fieldNo) = ret
                If fieldNo >= UBound(fieldData) Then

                    '出力処理
                    With Selection
                        For i = 1 To UBound(fieldData)
                            .Cells(1, i).Value = fieldData(i)
                        Next
                    End With
                    Selection.Offset(1).Select

                    fieldNo = 1
                    For i = 1 To UBound(fieldData)
                        fieldData(i) = Empty
                    Next
                Else
                    fieldNo = fieldNo + 1
                End If
            End If
        End If
    Loop
End Sub