第5回 フォームを使った顧客管理の作成 [顧客分類の追加]

今回は、前回までに作成した「顧客情報入力」フォームに「顧客分類」項目を追加し、顧客分類シートに事前登録した顧客分類をリスト選択入力できるよう機能追加し、「顧客検索」フォームも「顧客分類」で抽出できるよう機能追加する手順を紹介します。
koky014070.gif


＜機能追加手順＞
●第4回 フォームを使った顧客管理の作成 [名前定義の利用] で作成したファイルを開き、
シート「Sheet2」を「顧客分類」に名前の変更をし、「顧客分類」シートのセル「A1」に「顧客分類」と入力します。
koky014010.gif


「顧客情報」シートのG列に顧客分類用の列を挿入します。
koky014020.gif

セル「G1」を選択した状態で「名前の定義」ウィンドウを表示して、名前「顧客分類列」を追加します。(挿入したG列以降の名前定義のセル位置は自動変更されます)
koky014030.gif

●「Visual Basic Editor」を起動し、「frm顧客情報入力」フォームにラベルとコンボボックス(オブジェクト名：cmb顧客分類)を追加します。
koky014040.gif

入力順番の変更は、フォーム上を右クリックしてショートカットメニューの「タブオーダー」から設定します。
koky014050.gif

「frm顧客情報入力」フォームの処理を追加・変更します。
koky014060.gif

Private Sub UserForm_Initialize()
    Me.lbl行番号.Caption = Worksheets("顧客情報").Range("A1").CurrentRegion.Rows.Count + 1
    Call SetBunruiList
End Sub

Private Sub SetBunruiList()    '←顧客分類コンボボックスに顧客分類リストをセットする処理
    Dim wRow        As Long

    Me.cmb顧客分類.Clear
    For wRow = 2 To Worksheets("顧客分類").Range("A1").CurrentRegion.Rows.Count
        Me.cmb顧客分類.AddItem Worksheets("顧客分類").Cells(wRow, 1)
    Next
End Sub

Private Sub cmd先頭移動_Click()
    Call DspDataSet(2)
End Sub

Private Sub cmd前移動_Click()
    If Me.lbl行番号 > 1 Then
        Call DspDataSet(Me.lbl行番号 - 1)
    Else
        Call DspDataSet(1)
    End If
End Sub

Private Sub cmd次移動_Click()
    Dim wMaxRow As Long

    wMaxRow = Worksheets("顧客情報").Range("A1").CurrentRegion.Rows.Count
    If Me.lbl行番号 < wMaxRow Then
        Call DspDataSet(Me.lbl行番号 + 1)
    Else
        Call DspDataSet(wMaxRow)
    End If
End Sub

Private Sub cmd最終移動_Click()
    Dim wMaxRow As Long

    wMaxRow = Worksheets("顧客情報").Range("A1").CurrentRegion.Rows.Count
    Call DspDataSet(wMaxRow)
End Sub

Private Sub cmd新規_Click()
    Call DspDataSet(0)
End Sub

Private Sub cmd検索_Click()
    frm顧客検索.Show vbModal
    If rtnNo > 1 Then
        Call DspDataSet(rtnNo)
    End If
End Sub

Private Sub txt顧客名_AfterUpdate()
    If Me.txt顧客名 <> "" Then
        If Me.txtフリガナ = "" Then
            Me.txtフリガナ = StrConv(Application.GetPhonetic(Me.txt顧客名), vbNarrow)
        End If
    End If
End Sub

Private Sub cmd登録_Click()
    Dim wRow As Long

    If Me.txt顧客番号 = "" Then
        MsgBox "顧客番号を入力してください。", vbExclamation + vbOKOnly, "入力エラー"
        Exit Sub
    End If

    If Me.txt顧客名 = "" Then
        MsgBox "顧客名を入力してください。", vbExclamation + vbOKOnly, "入力エラー"
        Exit Sub
    End If

    With Worksheets("顧客情報")
        wRow = Me.lbl行番号.Caption
        .Cells(wRow, .Range("顧客番号列").Column) = Me.txt顧客番号
        .Cells(wRow, .Range("顧客名列").Column) = Me.txt顧客名
        .Cells(wRow, .Range("フリガナ列").Column) = Me.txtフリガナ
        .Cells(wRow, .Range("郵便番号列").Column) = Me.txt郵便番号
        .Cells(wRow, .Range("住所列").Column) = Me.txt住所
        .Cells(wRow, .Range("電話番号列").Column) = Me.txt電話番号
        .Cells(wRow, .Range("顧客分類列").Column) = Me.cmb顧客分類
        .Cells(wRow, .Range("備考列").Column) = Me.txt備考
    End With

    MsgBox "登録しました。", vbInformation + vbOKOnly, "Information"
End Sub

Private Sub DspDataSet(prmNo)
    With Worksheets("顧客情報")
        If prmNo > 1 Then
            Me.lbl行番号.Caption = prmNo
            Me.txt顧客番号 = .Cells(prmNo, .Range("顧客番号列").Column)
            Me.txt顧客名 = .Cells(prmNo, .Range("顧客名列").Column)
            Me.txtフリガナ = .Cells(prmNo, .Range("フリガナ列").Column)
            Me.txt郵便番号 = .Cells(prmNo, .Range("郵便番号列").Column)
            Me.txt住所 = .Cells(prmNo, .Range("住所列").Column)
            Me.txt電話番号 = .Cells(prmNo, .Range("電話番号列").Column)
            Me.cmb顧客分類 = .Cells(prmNo, .Range("顧客分類列").Column)
            Me.txt備考 = .Cells(prmNo, .Range("備考列").Column)
        Else
            Me.lbl行番号.Caption = .Range("A1").CurrentRegion.Rows.Count + 1
            Me.txt顧客番号 = ""
            Me.txt顧客名 = ""
            Me.txtフリガナ = ""
            Me.txt郵便番号 = ""
            Me.txt住所 = ""
            Me.txt電話番号 = ""
            Me.cmb顧客分類 = ""
            Me.txt備考 = ""
        End If
    End With
    Me.txt顧客番号.SetFocus
End Sub


●次に、「顧客検索」フォームに顧客分類での抽出機能を追加します。
「frm顧客情報入力」フォームと同じように「frm顧客検索」フォームへラベルとコンボボックス(オブジェクト名：cmb顧客分類)を追加します。
koky014100.gif

「frm顧客検索」フォームの処理を追加・変更します。
koky014110.gif

Private Sub UserForm_Initialize()
    rtnNo = 0
    Call SetBunruiList
    Call SetListBox
End Sub

Private Sub SetBunruiList()    '←顧客分類コンボボックスに顧客分類リストをセットする処理
    Dim wRow        As Long

    Me.cmb顧客分類.Clear
    For wRow = 2 To Worksheets("顧客分類").Range("A1").CurrentRegion.Rows.Count
        Me.cmb顧客分類.AddItem Worksheets("顧客分類").Cells(wRow, 1)
    Next
End Sub

Private Sub txt顧客名_Change()
    Call SetListBox
End Sub

Private Sub cmb顧客分類_Change()    '← 検索する顧客分類を選択した時の処理追加
    Call SetListBox
End Sub

Private Sub lst顧客リスト_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
    rtnNo = Me.lst顧客リスト.Text
    Unload Me
End Sub

Private Sub SetListBox()    '←リストボックスに表示する処理
    Dim wRow        As Long
    Dim wLstRow     As Long
    Dim wHitFlg     As Boolean

    Me.lst顧客リスト.Clear
    wLstRow = 0
    With Worksheets("顧客情報")
     For wRow = 2 To .Range("A1").CurrentRegion.Rows.Count
       wHitFlg = True
       If Me.txt顧客名 <> "" Then
         If InStr(1, .Cells(wRow, .Range("顧客名列").Column), Me.txt顧客名, vbTextCompare) = 0 Then
             wHitFlg = False
         End If
       End If
       If Me.cmb顧客分類 <> "" Then
         If .Cells(wRow, .Range("顧客分類列").Column) <> Me.cmb顧客分類 Then
             wHitFlg = False
         End If
       End If
       If wHitFlg = True Then
         Me.lst顧客リスト.AddItem ""
         Me.lst顧客リスト.List(wLstRow, 0) = wRow
         Me.lst顧客リスト.List(wLstRow, 1) = Worksheets("顧客情報").Cells(wRow, 2)
         wLstRow = wLstRow + 1
       End If
     Next
    End With
End Sub


＜完成＞
「顧客情報入力」フォームへ顧客分類項目が追加され、顧客分類シートに事前登録した顧客分類をリスト選択入力でき、「顧客検索」フォームも顧客分類で抽出できるようになりました。
koky014070.gif



次回は、今回作成したフォームに「生年月日」項目と年齢欄を追加し、年齢を自動計算表示するよう機能追加する手順を紹介します。
第6回 フォームを使った顧客管理の作成 [生年月日の追加]