VBAでの借用ならび返却記録

概要

今回はVBAでの借用ならび返却記録を試してみました。
学習のメモ程度に記述していますのでご承知ください。

動作環境

・windows：Windows11Pro 23H2

GUI　借用

コード　借用

Private Sub cmbStatus_Change()

End Sub

Private Sub ComboBox1_Click()
    Dim ws As Worksheet
    Dim lastRow As Long

    ' 記録シートを取得
    Set ws = ThisWorkbook.Sheets(1) ' 対象のシート名を確認して変更

    ' 最終行を取得
    lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row + 1

    ' ユーザーが入力した情報をシートに記録
    ws.Cells(lastRow, 1).Value = txtName.Value ' 氏名
    ws.Cells(lastRow, 2).Value = txtTitle.Value ' タイトル
    ws.Cells(lastRow, 3).Value = txtLocation.Value ' 保管場所
    ws.Cells(lastRow, 4).Value = cmbStatus.Value ' 返却状況
    
    If txtName.Text = "" Or txtTitle.Text = "" Or txtLocation.Text = "" Or cmbStatus.Text = "" Then
        MsgBox "全ての項目に値を入力してください。", vbExclamation
    Else
        
        ' メッセージ表示
        MsgBox "情報が登録されました！", vbInformation

        ' フォームをクリア
        txtName.Value = ""
        txtTitle.Value = ""
        txtLocation.Value = ""
        cmbStatus.Value = ""
    End If
    ' 未返却の行を緑色で塗りつぶす
    If ws.Cells(lastRow, 4).Value = "未返却" Then
        ws.Rows(lastRow).Interior.Color = RGB(144, 238, 144) ' ライトグリーン
    End If
End Sub

Private Sub ExitButton_Click()
  Unload Me
End Sub

Private Sub Label2_Click()

End Sub

Private Sub Label3_Click()

End Sub

Private Sub txtLocation_Change()

End Sub

Private Sub txtName_Change()

End Sub

Private Sub txtTitle_Change()

End Sub

Private Sub UserForm_Initialize()

    ' 返却状況のコンボボックスに値を追加
    With cmbStatus
        .AddItem "未返却"
        .AddItem "返却済み"
    End With

End Sub

GUI 返却

コード　返却

Private Sub btnReturn_Click()
    Dim ws As Worksheet
    Dim i As Long
    Dim targetTitle As String

    ' 記録シートの取得
    Set ws = ThisWorkbook.Sheets(1)

    ' リストボックスで選択されたタイトル
    If lstUnreturnedBooks.ListIndex = -1 Then
        MsgBox "未返却の本を選択してください。", vbExclamation
        Exit Sub
    End If
    targetTitle = lstUnreturnedBooks.Value

    ' シート内を検索して返却済みに変更
    For i = 4 To ws.Cells(ws.Rows.Count, 2).End(xlUp).Row
        If ws.Cells(i, 2).Value = targetTitle And ws.Cells(i, 4).Value = "未返却" Then
            ws.Cells(i, 4).Value = "返却済み"
            ' 塗りつぶしをリセット
            ws.Rows(i).Interior.ColorIndex = xlNone
            Exit For
        End If
    Next i

    ' リストボックスから削除
    lstUnreturnedBooks.RemoveItem lstUnreturnedBooks.ListIndex

    MsgBox "本が返却済みに変更されました。", vbInformation
End Sub

Private Sub ExitButton_Click()
    Unload Me
End Sub

Private Sub UserForm_Initialize()
    Dim ws As Worksheet
    Dim i As Long

    ' ワークシートの取得
    Set ws = ThisWorkbook.Sheets(1)

    ' リストボックスをクリア
    lstUnreturnedBooks.Clear

    ' 未返却の本をリストボックスに追加
    For i = 2 To ws.Cells(ws.Rows.Count, 2).End(xlUp).Row
        If ws.Cells(i, 4).Value = "未返却" Then
            lstUnreturnedBooks.AddItem ws.Cells(i, 2).Value
        End If
    Next i
End Sub