UserForm5
　


'-------------- [UserForm5] --------------

Dim Lbl As New Collection  'ラベルコレクション
Dim Txb As New Collection  'ボックスコレクション
Dim Bx As Integer          'フォーム内のラベル数
Dim Fnd As Range           '検索セル
Dim Cln As Long            'セル行ナンバー
Dim r As Long              'シート最終行

Private Sub CommandButton1_Click()
  '値転送
  '番号Txb(1) の数値をシートA列で検索
  r = Worksheets(1).Rows.Count
  With Worksheets(1).Range("A:A")
    Set Fnd = .Find(Txb(1), LookIn:=xlValues)  '検索セル
    'もし見つからなければレコード最終行の次の行
    If Fnd Is Nothing Then
      Cells(r, 1).End(xlUp).Offset(1).Select
      Cln = Val(Mid(Selection.Address(), 4, 3))
    Else
      'もし見つかればセル行ナンバー検出
      Cln = Val(Mid(Fnd.Address(), 4, 3))
    End If
  End With
    
  'テキストボックス値をシートセルに転送
  For i = 1 To Bx
    If Txb(i) <> "" Then
      If i = 2 Then
        Range(Chr(64 + i) & CStr(Cln)).Value = Txb(i)
      Else
        Range(Chr(64 + i) & CStr(Cln)).Value = Val(Txb(i))
      End If
    End If
  Next i
  
  'もしシートで次が入力済みなら次を表示
  If Range("A" & CStr(Cln + 1)).Value <> "" Then
    For j = 2 To Bx
      Txb(j) = Range(Chr(64 + j) & CStr(Cln + 1)).Value
    Next j
    Txb(1) = Range("A" & CStr(Cln + 1))
  Else
    '次が未入力ならボックス内データ消去
    For k = 2 To Bx
      Txb(k) = ""
    Next k
    Txb(1) = Range("A" & CStr(Cln + 1))
  End If
  TextBox3.SetFocus
End Sub
'--------------------------------------------------

Private Sub CommandButton2_Click()
  '次へ移動(スキップ)
  '番号Txb(1) の数値をシートA列で検索
  r = Worksheets(1).Rows.Count
  With Worksheets(1).Range("A:A")
    Set Fnd = .Find(Txb(1), LookIn:=xlValues)  '検索セル
    'もし見つからなければレコード最終行の次の行
    If Fnd Is Nothing Then
      Cells(r, 1).End(xlUp).Offset(1).Select
      Cln = Val(Mid(Selection.Address(), 4, 3))
    Else
      'もし見つかればセル行ナンバー検出
      Cln = Val(Mid(Fnd.Address(), 4, 3))
    End If
  End With
  
  'もしシートで次が入力済みなら次を表示
  If Range("A" & CStr(Cln + 1)).Value <> "" Then
    For j = 2 To Bx
      Txb(j) = Range(Chr(64 + j) & CStr(Cln + 1)).Value
    Next j
    Txb(1) = Range("A" & CStr(Cln + 1))
  Else
    '次が未入力ならボックス内データ消去
    Beep
    For k = 2 To Bx
      Txb(k) = ""
    Next k
    Txb(1) = Range("A" & CStr(Cln + 1))
  End If
  TextBox3.SetFocus
End Sub
'--------------------------------------------------

Private Sub CommandButton3_Click()
  '前に戻る
  '番号Txb(1) の数値をシートA列で検索
  r = Worksheets(1).Rows.Count
  With Worksheets(1).Range("A:A")
    Set Fnd = .Find(Txb(1), LookIn:=xlValues)  '検索セル
    'もし見つからなければレコード最終行の次の行
    If Fnd Is Nothing Then
      Cells(r, 1).End(xlUp).Offset(1).Select
      Cln = Val(Mid(Selection.Address(), 4, 3))
    Else
      'もし見つかればセル行ナンバー検出
      Cln = Val(Mid(Fnd.Address(), 4, 3))
    End If
  End With
  
  ' セル行ナンバー2ならExit
  If Cln = 2 Then
    Beep
    Exit Sub
  Else
    'もしシートで前が入力済みなら前を表示
    If Range("A" & CStr(Cln - 1)).Value <> "" Then
      For j = 2 To Bx
        Txb(j) = Range(Chr(64 + j) & CStr(Cln - 1)).Value
      Next j
      Txb(1) = Range("A" & CStr(Cln - 1))
    End If
  End If
  TextBox3.SetFocus
End Sub
'--------------------------------------------------

Private Sub TextBox1_Change()
  '番号の手処理にも対応
  r = Worksheets(1).Rows.Count
  If TextBox1.Value <> "" Then
    With Worksheets(1).Range("A:A")
      Set Fnd = .Find(Txb(1), LookIn:=xlValues)  '検索セル
      'もし見つからなければレコード最終行の次の行
      If Fnd Is Nothing Then
        Cells(r, 1).End(xlUp).Offset(1).Select
        Cln = Val(Mid(Selection.Address(), 4, 3))
      Else
        'もし見つかればセル行ナンバー検出
        Cln = Val(Mid(Fnd.Address(), 4, 3))
      End If
    End With
  
    'ボックスにシートデータを転記
    For j = 2 To Bx
      Txb(j) = Range(Chr(64 + j) & CStr(Cln)).Value
    Next j
  Else
    'ボックス内データ消去(番号以外)
    For k = 2 To Bx
      Txb(k) = ""
    Next k
  End If
End Sub
'--------------------------------------------------

Private Sub UserForm_Initialize()
  '初期設定
  Me.StartUpPosition = 0
  If Me.StartUpPosition = 0 Then
    Me.Top = 285
    Me.Left = 27
  End If
  
  'ラベルにコレクションを設定
  With Lbl
    .Add Item:=Label1
    .Add Item:=Label2
    .Add Item:=Label3
    .Add Item:=Label4
    .Add Item:=Label5
    .Add Item:=Label6
    .Add Item:=Label7
    .Add Item:=Label8
    .Add Item:=Label9
    .Add Item:=Label10
    .Add Item:=Label11
    .Add Item:=Label12
  End With
  
  'フォーム内のラベル数
  Bx = 12
  'ラベルに科目名を転記
  For i = 1 To Bx
    Lbl(i).Caption = _
    Range(Chr(64 + i) & "1").Value
  Next i
  
  'ボックスにコレクションを設定
  With Txb
    .Add Item:=TextBox1
    .Add Item:=TextBox2
    .Add Item:=TextBox3
    .Add Item:=TextBox4
    .Add Item:=TextBox5
    .Add Item:=TextBox6
    .Add Item:=TextBox7
    .Add Item:=TextBox8
    .Add Item:=TextBox9
    .Add Item:=TextBox10
    .Add Item:=TextBox11
    .Add Item:=TextBox12
  End With
  
  'ボックスにタブ順を設定
  For t = 1 To Bx
    Txb(t).TabIndex = i
  Next t
  
  'テキストボックスにセル値を初期表示
  If Range("A2").Value <> "" Then
    For j = 1 To Bx
      Txb(j) = Range(Chr(64 + j) & "2").Value
    Next j
  Else
    Txb(1) = 1
  End If
End Sub
'--------------------------------------------------

Private Sub CommandButton4_Click()
  '閉じる
  Unload UserForm5
End Sub
'--------------------------------------------------

                                                                 back top