VBA「PW設定ツール」に新機能を追加しました

'重複をチェックして設定値をワークシートに書き込む
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

'マルチページの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

'重複をチェックして設定値をワークシートに書き込むか削除するかを選択
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