VBA「PW設定ツール」に登録日時保存と表示データ削除機能を追加

スポンサーリンク

今回から UserForm を使用した「PW設定ツール」の細かい動作設定を調整していきます。
不足していると思った機能として、登録日時の保存と「設定シート」からも必要なくなった設定データを削除できるようにしていこうと思います。

くるみこ
くるみこ

ListView」と「ListBox」から保存データを削除できるようにしてきましたが「設定シート」からも表示されている設定データを削除できるように調整します。あわせて設定データの登録日時を保存するように設定します。(^^)

「設定シート」から表示している設定をそのまま削除できるようにするのは便利だと思います。それから登録日時も、設定してからどのくらい経過しているのかもわかるので良いと思います。よろしくお願いしますm(__)m

【この記事でわかること
・データ登録(保存)時に登録日時を保存する方法がわかります
コマンドボタンから保存データを削除できるようにする方法がわかります

前回記事のおさらいは、下のカードをクリックすれば開きます(^^ゞ

くるみこ
くるみこ

前回記事は「ListBox」の選択表示データを RowSourceで削除する方法の解説でした。是非覗いてみてね(^^)/

スポンサーリンク

設定データ保存時に登録日時を追加する

・登録した日時を保存しておいたほうが後々の管理がしやすくなると思います。
・ちなみに、GoogleFireFoxのWebで登録保存されているパスワードのデータをみると、いつ登録した設定なのかはわからないんですよね!
・というわけで「設定シート」の「登録」ボタンでPW設定データを保存する際に登録日時を追加して保存するように設定を調整します。

追加設定するために必要なこと

・Excelの「設定値」シートに列を追加します。列見出しは「Date」としました。
・VBAのコードで設定変更が必要な部分は次のとおりです。

・「登録」ボタンのクリックイベント「Private SubcmdSave_Click()」
・マルチページのChangeイベント「Private Sub MultiPage1_Change()」

「登録」ボタンのクリックイベントに設定追加

・最終列「Date」に登録時の日時を保存するように追加設定します。
・追加したのはたった1行(最後の行)だけです。Now 関数で現在日時を取得しています。
※記事最後に再度この部分のコードを掲載しているのでここでは省略表示しています。

'重複をチェックして設定値をワークシートに書き込む
Private Sub cmdSave_Click()
    Dim eRow As Long    '最終行

~ 中 略 ~

    With Worksheets("設定値")

~ 中 略 ~

        '指定セルにデータを書き込む(追加は最下部)
        .Cells(eRow, 1).Value = Cmb1.Text
        .Cells(eRow, 2).Value = Cmb2.Text
        .Cells(eRow, 3).Value = Cmb3.Text
        .Cells(eRow, 4).Value = Cmb4.Text
        .Cells(eRow, 5).Value = TxtBox0.Value
        .Cells(eRow, 6).Value = TxtBox1.Value
        .Cells(eRow, 7).Value = OptName
        .Cells(eRow, 8).Value = strSet
        .Cells(eRow, 9).Value = Now '登録時の日時(2011/05/15追加)
    End With
End Sub

・下が実行GIF画像です。「Date」列に日時が書き込まれているのご確認ください(^^♪

マルチページのChangeイベントに設定追加

・「ListBox」と「ListView」の列表示部分にコードを追加しました。
・追加行は「ListBox」が34行目、「ListView」が47行目です。行幅は変更していません。

'マルチページのChangeイベント
Private Sub MultiPage1_Change()
    Dim eRow As Long    '最終行用
    Dim LData As Range  'セル範囲指定用
    Dim i As Long       'ListItemループ用
    With Worksheets("設定値")
        eRow = .Cells(Rows.Count, 2).End(xlUp).Row
        Set LData = .Range(.Cells(2, 1), .Cells(eRow, 9))
    End With
    If MultiPage1.Value = 1 Then
        With ListBox1
            .ColumnCount = 9
            .ColumnHeads = True
            .ColumnWidths = "60;60;60;60;20;20;40"
            .RowSource = LData.Address
        End With
    ElseIf MultiPage1.Value = 2 Then
        With ListView1
            .AllowColumnReorder = True  '列幅の変更を許可
            .FullRowSelect = True       '行全体を選択
            .Gridlines = True           'グリッド線を表示
            .LabelEdit = lvwManual      'ラベル選択時編集しない
            .View = lvwReport   '表示設定「lvwList」はうまく表示しない
            '列見出しの設定
            .ColumnHeaders.Clear '初期化必須実行時エラー35602回避用
            .ColumnHeaders.Add 1, "Name", "名称", 60 ', lvwColumnLeft
            .ColumnHeaders.Add 2, "Bunrui", "分類", 60 ', lvwColumnCenter
            .ColumnHeaders.Add 3, "ID", "ID", 60 ', lvwColumnCenter
            .ColumnHeaders.Add 4, "M", "mKey", 60 ', lvwColumnCenter
            .ColumnHeaders.Add 5, "L", "開始", 20 ', lvwColumnCenter
            .ColumnHeaders.Add 6, "R", "終了", 20 ', lvwColumnCenter
            .ColumnHeaders.Add 7, "S", "記号", 40 ', , lvwColumnCenter
            .ColumnHeaders.Add 8, "Key", "Key" ', , lvwColumnCenter
            .ColumnHeaders.Add 9, "Date", "Date" ', , lvwColumnCenter '(2011/05/15追加)
            'ここからListItemのセット
            .ListItems.Clear
            For i = 1 To eRow - 1
                With .ListItems.Add
                    .Text = LData(i, 2)
                    .SubItems(1) = LData(i, 1)
                    .SubItems(2) = LData(i, 3)
                    .SubItems(3) = LData(i, 4)
                    .SubItems(4) = LData(i, 5)
                    .SubItems(5) = LData(i, 6)
                    .SubItems(6) = LData(i, 7)
                    .SubItems(7) = LData(i, 8)
                    .SubItems(8) = LData(i, 9) '(2011/05/15追加)
                End With
            Next
        End With
    End If
End Sub

・「ListBox」「ListView」ともに表示が追加されてていることが確認できます。

「登録」ボタンを「登録/削除」に変更します

・「登録」ボタンのクリックイベントに、データの削除を選択できるように機能を追加します。
MsgBox のレスポンスで Select Case を使って処理を分岐して使い分けします。
・次のようにVBAコードを変更しました。

「登録/削除」クリックイベントの変更したVBAコード

'重複をチェックして設定値をワークシートに書き込むか削除するかを選択
Private Sub cmdSave_Click()
    Dim eRow As Long    '最終行
    Dim i As Long       'ループカウンター用
    Dim rng1 As Range, rng2 As Range 'セル範囲
    Dim strSet As String    'Key文字列(A+B+C+D+E+F+G)
    Dim strName As String   '名称文字列(B列)
    Dim OptName As String   '記号オプション設定
    Dim re As Long
    Call cmdPW_Click    'PW生成する
    With Worksheets("設定値")
        eRow = .Cells(Rows.Count, 2).End(xlUp).Row + 1
        strName = Cmb1.Text & Cmb2.Text
        If strName = "" Then MsgBox "「名称」がありません!": Exit Sub
        Select Case True
            Case OptB1.Value: OptName = OptB1.Caption '任意
            Case OptB2.Value: OptName = OptB2.Caption '指定
            Case OptB3.Value: OptName = OptB3.Caption '禁止
        End Select
        strSet = Cmb1.Text & Cmb2.Text & Cmb3.Text & Cmb4.Text & _
                            TxtBox0.Value & TxtBox1.Value & OptName
        If strSet = "" Then MsgBox "「Key」がありません!": Exit Sub
        Set rng1 = Range(.Cells(2, 5), .Cells(eRow, 5))
        '同じItemが存在するかチェックする
        For i = 1 To rng1.Count
            If rng1(i).Value = strSet Then
                MsgBox "重複データのため登録しませんでした!"
                Exit Sub
            End If
        Next
        'Keyに重複が無かった場合、分類+名称で再チェック
        Set rng1 = Range(.Cells(2, 1), .Cells(eRow, 1))
        Set rng2 = Range(.Cells(2, 2), .Cells(eRow, 2))
        '同じ名称が存在するかチェックする
        For i = 1 To rng1.Count
            If rng1(i).Value & rng2(i).Value = strName Then
                re = MsgBox("同じ名称があります!書き換えますか?" _
                    & vbCrLf & "※「削除」する場合は「いいえ」を選択!", _
                                        vbYesNoCancel + vbExclamation)
                Select Case re
                    Case vbYes
                    'データを上書きさせるため
                        eRow = i + 1 'eRowにセルの行番号を代入
                    Case vbNo
                        re = MsgBox("データを削除しますか?" _
                                , vbYesNo + vbExclamation)
                        If re = vbYes Then .Rows(i + 1).Delete '行を削除
                        Exit Sub
                    Case vbCancel
                        Exit Sub
                End Select
            End If
        Next
        '指定セルにデータを書き込む(追加は最下部)
        .Cells(eRow, 1).Value = Cmb1.Text
        .Cells(eRow, 2).Value = Cmb2.Text
        .Cells(eRow, 3).Value = Cmb3.Text
        .Cells(eRow, 4).Value = Cmb4.Text
        .Cells(eRow, 5).Value = TxtBox0.Value
        .Cells(eRow, 6).Value = TxtBox1.Value
        .Cells(eRow, 7).Value = OptName
        .Cells(eRow, 8).Value = strSet
        .Cells(eRow, 9).Value = Now '登録時の日時(2011/05/15追加)
    End With
End Sub

コードを変更した部分
・36行目、MsgBoxvbYesNoCancel」の3ボタン表示に変更して、「削除」を選択できるようにメッセージ内容を変更しています。
・40行目、MsgBoxのレスポンスを Select Case で条件分岐するように変更しています。
・41~43行目、「はい」選択の場合、対象行を変数に代入して55行目以降の処理移ります。
・44~48行目、「いいえ」選択の場合、再度メッセージで削除するかどうかの確認を求めます。
・47行目、「はい」が選択された場合、シートの対象行を削除します。
・48行目、Subプロシージャを抜けます。
・49行目、「キャンセル」選択の場合は、次の50行目でSubプロシージャを抜けます。
設定シートの変更部分
PW文字列のテキストボックス右上部分に、保存日時を表示するようにラベルを追加しています
・下のGIF画像で変更内容が確認できると思います。

保存日時の追加と「設定シート」から保存データ行の削除ができるようになったので、今回はここで終了とします!

スポンサーリンク

まとめ(おわりに)

・いかがでしたでしょうか?
・今回も、記事内で使用したコードのサンプルファイルを登録していますのでご利用ください。
今までの記事のサンプルも登録していますのでよろしければお使いください(^^)

まとめと感想など

くるみこ
くるみこ

設定保存日時の追加は「Now関数」で簡単に設定できましたね。変更した箇所も少なかったので楽でしたね(^^)
削除」については、はじめはボタンを追加するかどうか迷いました。でも「登録」ボタンを併用で使えばスッキリするので、MsgBoxのレスポンスで全く違った処理に分岐するように設定してみました。

そうですね、一度ボタンを追加してみたら、サイズも小さくなって密集してるのでカッコ悪くなっちゃいましたよね(^^;
次回はどんな内容になるのか楽しみです(^^♪

くるみこ
くるみこ

次回までに、不足している機能が無いかなど、いっぱいテストを重ねてみましょう! 結果、足りない部分が無ければ、UserFormの表示設定や終了時の動作設定などを行って仕上げていきます。楽しみにしていてね(^^)/

【今回わかったことは】
・データ登録(保存)時に「Now関数」で登録日時を保存する方法がわかりました
・一つのコマンドボタンから MsgBox のレスポンスを使って処理を分岐して機能を追加する方法がわかりました

★★★ ランキング参加中! クリックしてね(^^)/ ★★★

今後の記事について

今回の記事はいかがだったでしょうか。皆さまのお役に立てたなら幸いです(^^;
「汎用でだれでも使えて活用できるように考えてVBAを使う」というポリシーで、記事を継続して書いていきたいと思っています。どうぞよろしくお願いしますm(_ _)m

【検討中の今後の記事内容は・・・・・】
・実務に役立つものを提供できるよう常に検討しています(^^ゞ
・その他雑記的に「プチネタなど」もいろいろ考えていきたいと思います・・・・・
・今後の記事にもご期待ください(^^)/

記事のサンプルファイルをダウンロードできます

今回の記事のサンプルをダウンロードできるようにしています
過去の記事で使用したサンプルファイルがダウンロードできるページを設置しています
こちら(このリンク先)からご利用ください