LoginSignup
0
0

More than 3 years have passed since last update.

@freelanceradiation(かずや)

Excelで顧客管理できるかやってみた[VBA]

Posted at

題名の通り、Excelで顧客管理できるかやってみました。
今回は顧客名、連絡先、メールアドレスを管理すると仮定していきます。

前提

2シート：登録シート（登録、一覧表示、更新、削除）ができ、すべての処理はここで行う
　　　　 データシート（データが入ってくるところ）←今回は触らない

画面

登録シート
ev009.JPG

登録処理
ev010.JPG

一覧表示、更新、削除処理
ev011.JPG

データシート
ev012.JPG

実装

標準モジュール

フォームを開く処理を書きます。

Module1
Option Explicit

'登録
Sub ボタン1_Click()
 UserForm1.Show
End Sub

'一覧
Sub ボタン2_Click()
 UserForm2.Show
End Sub

フォーム

フォーム内の処理書きます。

UserForm1
Option Explicit

'
'起動時プレースホルダ作成
'
Private Sub UserForm_Initialize()

    '起動時プレースホルダの文字を薄いグレーにする

    With TXT_顧客名
        .ForeColor = RGB(192, 192, 192)
        .Text = "伊藤太郎"
    End With

    With TXT_連絡先
        .ForeColor = RGB(192, 192, 192)
        .Text = "080-1829-5734"
    End With

    With TXT_メールアドレス
        .ForeColor = RGB(192, 192, 192)
        .Text = "test@gmail.com"
    End With

End Sub

'
'プレースホルダ削除処理
'
Private Sub TXT_顧客名_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)

    'プレースホルダが薄いグレーだった場合はテキストボックスを空にする

    If TXT_顧客名.ForeColor = RGB(192, 192, 192) Then
        With TXT_顧客名
            .Text = ""
            .ForeColor = RGB(0, 0, 0)
        End With
    End If

End Sub

Private Sub TXT_連絡先_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
    If TXT_連絡先.ForeColor = RGB(192, 192, 192) Then
        With TXT_連絡先
            .Text = ""
            .ForeColor = RGB(0, 0, 0)
        End With
    End If
End Sub

Private Sub TXT_メールアドレス_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
    If TXT_メールアドレス.ForeColor = RGB(192, 192, 192) Then
        With TXT_メールアドレス
            .Text = ""
            .ForeColor = RGB(0, 0, 0)
        End With
    End If
End Sub

'
'フォーカスがテキストボックスから外れた時の処理
'
Private Sub TXT_顧客名_Exit(ByVal Cancel As MSForms.ReturnBoolean)

    'フォーカスがテキストボックスから外れた際に顧客名の値が空だった場合、
    'プレースホルダを作成し文字を薄いグレーにする

    If TXT_顧客名 = "" Then
        With TXT_顧客名
            .ForeColor = RGB(192, 192, 192)
            .Text = "2019/10/5"
        End With
    End If

End Sub

Private Sub TXT_連絡先_Exit(ByVal Cancel As MSForms.ReturnBoolean)
    If TXT_連絡先 = "" Then
        With TXT_連絡先
            .ForeColor = RGB(192, 192, 192)
            .Text = "080-1829-5734"
        End With
    End If
End Sub

Private Sub TXT_メールアドレス_Exit(ByVal Cancel As MSForms.ReturnBoolean)
    If TXT_メールアドレス = "" Then
        With TXT_メールアドレス
            .ForeColor = RGB(192, 192, 192)
            .Text = "test@gmail.com"
        End With
    End If
End Sub

'
'データ登録処理
'
Private Sub BT_登録_Click()

Dim lastRowA        As Long  'A列の最後まで
Dim lastRowB        As Long 'B列の最後まで
Dim lastRowC        As Long 'C列の最後まで
Dim myRegEx         As RegExp '正規表現
Dim regCheck        As Boolean
Dim bRow            As Range
Dim cRow            As Range
Dim i               As Long


Set myRegEx = New RegExp

'バリデーション

    '顧客（空チェック）
    If TXT_顧客名.Text = "" Then
        MsgBox "顧客名を入力してください。"
        Exit Sub
      End If


    '連絡先（空、形式、重複チェック）
    If TXT_連絡先.Text = "" Then
        MsgBox "連絡先を入力してください。"
        Exit Sub
      End If

    myRegEx.Pattern = "\d{2,4}-\d{2,4}-\d{4}"
    regCheck = myRegEx.Test(TXT_連絡先.Text)
    If regCheck = False Then
        MsgBox "電話番号の形式にして下さい。"
        Exit Sub
    End If

    lastRowB = Worksheets("データ").Cells(rows.Count, 2).End(xlUp).Row

    For i = 2 To lastRowB
        For Each bRow In Worksheets("データ").Cells(i, 2)
            If bRow.Value = TXT_連絡先.Text Then
                MsgBox "連絡先は重複しています"
                Exit Sub
            End If
        Next bRow
    Next i

    'メールアドレス（空、形式、重複チェック）
    If TXT_メールアドレス.Text = "" Then
        MsgBox "メールアドレスを入力してください。"
        Exit Sub
      End If

    myRegEx.Pattern = "^\S+@\S+\.\S+$"
    regCheck = myRegEx.Test(TXT_メールアドレス.Text)
    If regCheck = False Then
        MsgBox "メールアドレスの形式にして下さい。"
        Exit Sub
    End If

    lastRowC = Worksheets("データ").Cells(rows.Count, 3).End(xlUp).Row

    For i = 2 To lastRowC
        For Each cRow In Worksheets("データ").Cells(i, 3)
            If cRow.Value = TXT_メールアドレス.Text Then
                MsgBox "メールアドレスは重複しています"
                Exit Sub
            End If
        Next cRow
    Next i


'登録
    With Worksheets("データ")
        lastRowA = .Cells(rows.Count, 1).End(xlUp).Row + 1
        .Cells(lastRowA, 1).Value = TXT_顧客名.Text
        .Cells(lastRowA, 2).Value = TXT_連絡先.Text
        .Cells(lastRowA, 3).Value = TXT_メールアドレス.Text
    End With

'テキストボックス初期状態
    TXT_顧客名.Text = ""
    TXT_連絡先.Text = ""
    TXT_メールアドレス.Text = ""


    MsgBox "登録しました。"

    Set myRegEx = Nothing


End Sub
UserForm2
Option Explicit

'
'起動時、リストボックス内データ取得
'
Private Sub UserForm_Initialize()
    Dim lastrow As Long

    lastrow = Sheets("データ").Cells(rows.Count, 1).End(xlUp).Row

    With ListBox1
        .ColumnHeads = True
        .ColumnCount = 3
        .ColumnWidths = "60;100;50"
        .RowSource = "データ!" & Range("A2", "C" & lastrow).Address
    End With
End Sub

'
'リストボックス内の値をテキストボックスに挿入
'
Private Sub ListBox1_Click()

      'テキストボックスに値挿入
      TXT_顧客名.Text = Me.ListBox1.List(Me.ListBox1.ListIndex, 0)
      TXT_連絡先.Text = Me.ListBox1.List(Me.ListBox1.ListIndex, 1)
      TXT_メールアドレス.Text = Me.ListBox1.List(Me.ListBox1.ListIndex, 2)

End Sub


'
'データ編集処理
'
Private Sub BT_変更_Click()
    Dim rowEx  As String
    Dim i     As Integer
    Dim rc    As VbMsgBoxResult
    Dim strEdit(0, 2) As String ' 二次元配列
    Dim myRegEx         As RegExp '正規表現
    Dim regCheck        As Boolean
    Dim bRow            As Range
    Dim cRow            As Range
    Dim lastRowB        As Long 'B列の最後まで
    Dim lastRowC        As Long 'C列の最後まで

    Set myRegEx = New RegExp

    rc = MsgBox("変更してもよろしいですか？", vbYesNo + vbQuestion, "変更の確認")

    '選択
    If rc = vbYes Then
      With UserForm2.ListBox1
        For i = 0 To .ListCount - 1 'リストボックスの行数
          If .Selected(i) Then '選択されていた場合
            If rowEx = "" Then
              rowEx = i + 2 '1こめのとき
            Else
              rowEx = rowEx & ", " & i + 2 '複数あるとき
            End If
          End If
        Next i
      End With
      If rowEx = "" Then
        MsgBox "選択されていません"
      End If

'バリデーション

    '顧客（空チェック）
    If TXT_顧客名.Text = "" Then
        MsgBox "顧客名を入力してください。"
        Exit Sub
      End If


    '連絡先（空、形式、重複チェック）
    If TXT_連絡先.Text = "" Then
        MsgBox "連絡先を入力してください。"
        Exit Sub
      End If

    myRegEx.Pattern = "\d{2,4}-\d{2,4}-\d{4}"
    regCheck = myRegEx.Test(TXT_連絡先.Text)
    If regCheck = False Then
        MsgBox "電話番号の形式にして下さい。"
        Exit Sub
    End If

    lastRowB = Worksheets("データ").Cells(rows.Count, 2).End(xlUp).Row

    For i = 2 To lastRowB
        For Each bRow In Worksheets("データ").Cells(i, 2)
            '連絡先データとテキストボックスの値が一致した場合、処理実行しない
            If bRow.Value = TXT_連絡先.Text Then
                '連絡先データと選択したデータが同じだった場合、ループを抜ける
                If bRow.Value = Worksheets("データ").Cells(CInt(rowEx), 2).Value Then
                    Exit For
                End If

                MsgBox "連絡先は重複しています"
                Exit Sub
            End If
        Next bRow
    Next i

    'メールアドレス（空、形式、重複チェック）
    If TXT_メールアドレス.Text = "" Then
        MsgBox "メールアドレスを入力してください。"
        Exit Sub
      End If

    myRegEx.Pattern = "^\S+@\S+\.\S+$"
    regCheck = myRegEx.Test(TXT_メールアドレス.Text)
    If regCheck = False Then
        MsgBox "メールアドレスの形式にして下さい。"
        Exit Sub
    End If

    lastRowC = Worksheets("データ").Cells(rows.Count, 3).End(xlUp).Row

    For i = 2 To lastRowC
        For Each cRow In Worksheets("データ").Cells(i, 3)
            If cRow.Value = TXT_メールアドレス.Text Then
                If cRow.Value = Worksheets("データ").Cells(CInt(rowEx), 3).Value Then
                    Exit For
                End If

                MsgBox "メールアドレスは重複しています"
                Exit Sub
            End If
        Next cRow
    Next i

      '変更
      strEdit(0, 0) = TXT_顧客名.Text
      strEdit(0, 1) = TXT_連絡先.Text
      strEdit(0, 2) = TXT_メールアドレス.Text
      Worksheets("データ").Range("A" & rowEx & ":" & "C" & rowEx).Value = strEdit

      MsgBox "変更を実行しました", vbInformation

    Else
      MsgBox "変更を中止します"
    End If

End Sub

'
'データ削除処理
'
Private Sub BT_削除_Click()
    Dim rows  As String
    Dim i     As Integer
    Dim rc    As VbMsgBoxResult

    rc = MsgBox("削除してもよろしいですか？", vbYesNo + vbExclamation, "削除の確認")

    '選択
    If rc = vbYes Then
      With UserForm2.ListBox1
        For i = 0 To .ListCount - 1 'リストボックスの行数
          If .Selected(i) Then '選択されていた場合
            If rows = "" Then
              rows = i + 2 '1こめのとき
            Else
              rows = rows & ", " & i + 2 '複数あるとき
            End If
          End If
        Next i
      End With
      If rows = "" Then
        MsgBox "選択されていません"
        Exit Sub
      End If

      '削除
      Worksheets("データ").rows(rows).Delete

      MsgBox "削除を実行しました", vbInformation

    Else
      MsgBox "削除を中止します"
    End If

End Sub

感想

・応用すればもっといいやつが作れそう。
・Macだと使えないオブジェクト、フォーム自体が使えないなどあるので考慮しないといけない。
・やってよかった

0
0
0

Register as a new user and use Qiita more conveniently

  1. You get articles that match your needs
  2. You can efficiently read back useful information
  3. You can use dark theme
What you can do with signing up
Sign upLogin
0
0