個人情報管理アプリ（VBA）ver.2

ThisWorkbook

'******************************************************************
'エクセル起動時にメニューシートを開く
'******************************************************************

Private Sub Workbook_Open()
    Worksheets("メニュー").Select
End Sub

UserForm1

'
'＝＝＝＝＝＝＝＝＝＝データ入力画面コード＝＝＝＝＝＝＝＝＝＝


'******************************************************************
'フォームの読み込み中に発生するInitialize（初期化）イベントの処理
'******************************************************************

Private Sub UserForm_Initialize()
    Worksheets("個人情報データ").Select
    IDLabel.Caption = Format(Now, "ARL" & "yyyymmddHHMMSS")
    SexComboBox.AddItem "男性"
    SexComboBox.AddItem "女性"
End Sub

'**********************************************************
'「メニュー」ボタンをクリックしたときの処理
'**********************************************************

Private Sub MenuButton_Click()
    Worksheets("メニュー").Select
    UserForm1.Hide
End Sub

'******************************************************************
'コンボボックスの値が変化した時の処理
'******************************************************************

Private Sub SexComboBox_Change()
    My_Sex = SexComboBox.Value
End Sub

'******************************************************************
'「登録」ボタンがクリックされたときの処理
'******************************************************************

Private Sub RegisterButton_Click()

    Dim myRegEx As New RegExp
    Dim regCheck As Boolean
    Dim a As Integer

    'エラー文一覧
    If NameTextBox.Text = "" Then
        MsgBox "氏名を入力してください。"
        Exit Sub
    End If
    
    My_Sex = SexComboBox
    If My_Sex = "" Then
        MsgBox "性別を選択してください。"
        Exit Sub
    End If

    If BirthdayTextBox.Text = "" Then
        MsgBox "誕生日を入力してください。"
        Exit Sub
   End If

    If PpstalCodeTextBox.Text = "" Then
        MsgBox "郵便番号を入力してください。"
       Exit Sub
    End If

    If AddressTextBox.Text = "" Then
       MsgBox "住所を入力してください。"
        Exit Sub
    End If

   If PhoneNumberTextBox.Text = "" Then
        MsgBox "電話番号を入力してください。"
        Exit Sub
    End If

   If MailTextBox.Text = "" Then
        MsgBox "メールを入力してください。"
        Exit Sub
    End If

  '生年月日正規表現チェック'
    myRegEx.Pattern = "\d{4}/\d{1,2}/\d{1,2}$"
    regCheck = myRegEx.test(BirthdayTextBox.Text)
    If regCheck = False Then
        MsgBox "生年月日が不正です。"
        Exit Sub
    End If

  '生年月日の日付整合性確認
    If IsDate(BirthdayTextBox) = False Then
        MsgBox "その日付は存在しません。"
        Exit Sub
    End If


   '郵便番号正規表現チェック'
    myRegEx.Pattern = "\d{3}-\d{4}$"
    regCheck = myRegEx.test(PpstalCodeTextBox.Text)
   If regCheck = False Then
        MsgBox "郵便番号が不正です。"
        Exit Sub
    End If

  '電話番号正規表現チェック'
    myRegEx.Pattern = "\d{2,4}-\d{2,4}-\d{4}$"
    regCheck = myRegEx.test(PhoneNumberTextBox.Text)
    If regCheck = False Then
        MsgBox "電話番号が不正です。"
        Exit Sub
    End If
  'メール正規表現チェック'
    myRegEx.Pattern = "[\w\.\-]+@[\w\.-]+\.[a-zA-Z]{2,6}$"
    regCheck = myRegEx.test(MailTextBox.Text)
   If regCheck = False Then
        MsgBox "メールアドレスが不正です。"
        Exit Sub
    End If
 
  'データの登録'
    Dim lastRow As Long
    With Worksheets("個人情報データ")
        lastRow = .Cells(Rows.Count, 1).End(xlUp).Row + 1
        .Cells(lastRow, 1).Value = IDLabel.Caption
        .Cells(lastRow, 2).Value = NameTextBox.Text
        .Cells(lastRow, 3).Value = My_Sex
        .Cells(lastRow, 4).Value = BirthdayTextBox
        .Cells(lastRow, 5).Value = PpstalCodeTextBox
        .Cells(lastRow, 6).Value = AddressTextBox.Text
        .Cells(lastRow, 7).Value = PhoneNumberTextBox
        .Cells(lastRow, 8).Value = MailTextBox.Text
     End With
    
    MsgBox (NameTextBox & " 様が追加されました。")
End Sub

UserForm2

'
'＝＝＝＝＝＝＝＝＝＝データ検索、削除画面コード＝＝＝＝＝＝＝＝＝＝


'**********************************************************
'フォームがアクティブになったときの処理
'**********************************************************

Private Sub UserForm_Activate()
    If flag = True Then
        DeleteButton.Visible = True
    Else
        DeleteButton.Visible = False
    End If
    Worksheets("個人情報データ").Activate
End Sub

'**********************************************************
'「メニュー」ボタンをクリックしたときの処理
'**********************************************************

Private Sub MenuButton_Click()
    Worksheets("メニュー").Select
    UserForm2.Hide
End Sub

'**********************************************************
'「氏名オプションボタン」をクリックしたときの処理
'**********************************************************

Private Sub NameOptionButton_Click()
    
    Determine = 1 'Determine = 判定
    SearchAddressTextBox.Text = ""
    SearchPhoneNumberTextBox.Text = ""
    ListBox.Clear
    NameButton.Enabled = True
    AddressBottun.Enabled = False
    PhoneNumberButton.Enabled = False
    
    Dim i As Long
    lastRow = Worksheets("個人情報データ").Cells(Rows.Count, 2).End(xlUp).Row + 1
    
        If lastRow <= 2 Then
            MsgBox "データはありません。"
            Exit Sub
        End If
    
    For i = 2 To lastRow
        ListBox.AddItem Cells(i, 2) '氏名
    Next
    NumberLabel.Caption = ListBox.ListCount - 1 & "件"
End Sub


'**********************************************************
'「住所オプションボタン」をクリックしたときの処理
'**********************************************************

Private Sub AddressOptionButton_Click()
    
    Determine = 2
    SearchNameTextBox.Text = ""
    SearchPhoneNumberTextBox.Text = ""
    ListBox.Clear
    NameButton.Enabled = False
    AddressBottun.Enabled = True
    PhoneNumberButton.Enabled = False
    
    Dim i As Long
    lastRow = Worksheets("個人情報データ").Cells(Rows.Count, 2).End(xlUp).Row + 1
    
    If lastRow <= 2 Then
        MsgBox "データはありません。"
        Exit Sub
    End If
    
    For i = 2 To lastRow
        ListBox.AddItem Cells(i, 6) '氏名
    Next
    NumberLabel.Caption = ListBox.ListCount - 1 & "件"
End Sub

'**********************************************************
'「電話番号オプションボタン」をクリックしたときの処理
'**********************************************************

Private Sub PhoneNumberOptionButton_Click()
 
    Determine = 3
    SearchNameTextBox.Text = ""
    SearchAddressTextBox.Text = ""
    ListBox.Clear
    NameButton.Enabled = False
    AddressBottun.Enabled = False
    PhoneNumberButton.Enabled = True
    
    Dim i As Long
    lastRow = Worksheets("個人情報データ").Cells(Rows.Count, 2).End(xlUp).Row + 1
    
    If lastRow <= 2 Then
        MsgBox "データはありません。"
        Exit Sub
    End If
    
    For i = 2 To lastRow
        ListBox.AddItem Cells(i, 7) '氏名
    Next
    NumberLabel.Caption = ListBox.ListCount - 1 & "件"
End Sub


'**********************************************************
'「氏名ボタン」の「実行」ボタンをクリックしたときの処理
'**********************************************************

Private Sub NameButton_Click()
    Call SearchStart(SearchNameTextBox.Text)
End Sub

'**********************************************************
'「住所ボタン」の「実行」ボタンをクリックしたときの処理
'**********************************************************

Private Sub AddressBottun_Click()
    Call SearchStart(SearchAddressTextBox.Text)
End Sub

'**********************************************************
'「電話番号ボタン」の「実行」ボタンをクリックしたときの処理
'**********************************************************

Private Sub PhoneNumberButton_Click()
    Call SearchStart(SearchPhoneNumberTextBox.Text)
End Sub

'**********************************************************
'「検索実行」プロシージャの処理
'**********************************************************

Private Sub SearchStart(SearchSubject As String)
    Dim searchName As String
    searchName = SearchSubject
    
    If searchName = "" Then
        MsgBox "検索する対象を入力してください。"
    Else
        Dim i As Long
        Dim no As Long
        For i = 0 To ListBox.ListCount - 1
            If ListBox.List(i) = searchName Then
                no = i
                ListBox.ListIndex = no
            End If
            Next
        Index = no + 2
        Worksheets("個人情報データ").Select
        Rows(Index).Select
        
        Dim xlLineNumber As Integer
        
        xlLineNumber = ActiveCell.Row
        
        IDLabel.Caption = Cells(xlLineNumber, 1)
        NameLabel.Caption = Cells(xlLineNumber, 2)
        SexLabel.Caption = Cells(xlLineNumber, 3)
        BirthdayLabel.Caption = Cells(xlLineNumber, 4)
        PostalCodeLabel.Caption = Cells(xlLineNumber, 5)
        AddressLabel.Caption = Cells(xlLineNumber, 6)
        PhoneNumberLabel.Caption = Cells(xlLineNumber, 7)
        MailLabel.Caption = Cells(xlLineNumber, 8)
    End If
End Sub

'**********************************************************
'「一覧リストボックス」から値を選択したときの処理
'**********************************************************

Private Sub ListBox_Click()
 On Error GoTo エラー
    If Determine = 1 Then
        SearchNameTextBox.Text = ListBox.List(ListBox.ListIndex)
    End If
    
    If Determine = 2 Then
        SearchAddressTextBox.Text = ListBox.List(ListBox.ListIndex)
    End If

    If Determine = 3 Then
        SearchPhoneNumberTextBox.Text = ListBox.List(ListBox.ListIndex)
    End If

エラー:
    Exit Sub
End Sub
    
'**********************************************************
'削除実行の処理
'**********************************************************
    
Private Sub DeleteButton_Click()
    If IDLabel.Caption = "" Then
        MsgBox ("削除対象が指定されておりません。")
        Exit Sub
    End If
 
    Dim ConfirmDelete As Integer
    ConfirmDelete = MsgBox("削除しますか？", vbYesNo + vbExclamation, "ConfirmDelete")
    
    If ConfirmDelete = vbYes Then
        Worksheets("個人情報データ").Select
        
        Dim xlLineNumber As Integer
        xlLineNumber = ActiveCell.Row
        
        Range(Cells(xlLineNumber, 1), Cells(xlLineNumber, 8)).Delete
        MsgBox "削除しました。"
        
        IDLabel.Caption = ""
        NameLabel.Caption = ""
        SexLabel.Caption = ""
        BirthdayLabel.Caption = ""
        PostalCodeLabel.Caption = ""
        AddressLabel.Caption = ""
        PhoneNumberLabel.Caption = ""
        MailLabel.Caption = ""
        SearchNameTextBox.Text = ""
        SearchAddressTextBox.Text = ""
        SearchPhoneNumberTextBox.Text = ""
        
        NameButton.Enabled = False
        AddressBottun.Enabled = False
        PhoneNumberButton.Enabled = False
        
            If NameOptionButton = True Then
                Call NameOptionButton_Click
            End If
            
            If AddressOptionButton = True Then
                Call AddressOptionButton_Click
            End If
            
            If PhoneNumberOptionButton = True Then
                 Call PhoneNumberOptionButton_Click
            End If
    Else
        MsgBox "削除を中止しました。"
        Exit Sub
    End If
    
End Sub

UserForm3

'
'＝＝＝＝＝＝＝＝＝＝印刷プレビュー画面コード＝＝＝＝＝＝＝＝＝＝


'*****************************************************
'印刷設定がアクティブになった時の処理
'*****************************************************

Private Sub UserForm_Activate()
    Worksheets("個人情報データ").Select
End Sub


'*****************************************************
'印刷設定がアクティブになった時の処理
'*****************************************************

Private Sub PreviewButton_Click()
    With Worksheets("個人情報データ").PageSetup
        .Orientation = xlLandscape '横向きに印刷
        .Zoom = 65
        .PrintArea = PrintRange.Text
        .PrintTitleRows = HeadingLine.Text
        .PrintTitleColumns = ""
        .RightFooter = "&P/&Nページ"  'ページ番号/総ページ数
        .LeftFooter = "&P:&A" 'ファイル名：シート見出し名
    End With
    
    UserForm3.Hide
    Worksheets("個人情報データ").PrintPreview
    
    If PrintPreview_Close Then
        PrintOptionWindw.Select
    End If
    
End Sub

'*****************************************************
'メニューボタンをクリックしたときの処理
'*****************************************************

Private Sub MenuButton_Click()
    Worksheets("メニュー").Select
    UserForm3.Hide
End Sub

UserForm4

'
'＝＝＝＝＝＝＝＝＝＝印刷プレビュー画面コード＝＝＝＝＝＝＝＝＝＝


'*****************************************************
'印刷とPDF実行がアクティブになった時の処理
'*****************************************************

Private Sub UserForm_Activate()
    Worksheets("個人情報データ").Select
End Sub

'*****************************************************
'メニューボタンがクリックされた時の処理
'*****************************************************

Private Sub MenuButton_Click()
    Worksheets("メニュー").Select
    UserForm4.Hide
End Sub

'*****************************************************
'印刷オプションボタンがクリックされた時の処理
'*****************************************************

Private Sub PrintOB_Click()
    CopiesBox.Enabled = True
    PDFB.Enabled = False
    PrintB.Enabled = True
End Sub


'*****************************************************
'PDF化オプションボタンがクリックされた時の処理
'*****************************************************

Private Sub PDFOB_Click()
    PDFB.Enabled = True
    CopiesBox.Enabled = False
    PrintB.Enabled = False
End Sub

'*****************************************************
'印刷実行ボタンがクリックされた時の処理
'*****************************************************

Private Sub PrintB_Click()
    If CopiesBox.Text = "" Or IsNumeric(CopiesBox.Text) = False Then
        MsgBox "印刷部数が入力されていないか、入力された値が不正です。"
        Exit Sub
    Else
        ActiveSheet.PrintOut Copies:=CopiesBox.Text
    End If
End Sub

'*****************************************************
'PDFに書き起こすボタンがクリックされた時の処理
'*****************************************************

Private Sub PDFB_Click()
    Dim SaveFileName As String
      
    'Application.GetSaveAsFile
    '   = 拡張子を指示してファイル保存ダイアログを表示させるメソッド
    SaveFileName = Application.GetSaveAsFilename(, "PDFファイル,*.pdf")
    
    'ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=""
    '   = PDFに変換する
    ActiveSheet.ExportAsFixedFormat _
    Type:=xlTypePDF, FileName:=SaveFileName
    
End Sub

シート設定

'*************************************************************
'シートの名前を変更する
'*************************************************************
Sub my_SheetsName() 'Sheet1変更

    Worksheets("Sheet1").Name = "メニュー"
End Sub

'*************************************************************
'シートの追加とセルの設定反映
'*************************************************************

Sub my_SheetsAdd()  'Sheet2を追加
    Worksheets.Add(After:=Worksheets("メニュー")).Name = "個人情報データ"
    
    Dim AddCellsName As String
    Dim AddCellsWidth As Integer
    Dim AddCellsColor As Integer
    
    CellsName = CellOption1(AddCellsName)       'セルに文字を入れる
    CellsWidth = CellOption2(AddCellsWidth)     'セルの幅変更
    CellsColor = CellOption3(AddCellsColor)     'セルの色選択
    CellsFont = CellOption4()                   'セル内のフォント変更
    CellsLine = CellOption5()                   'セルの罫線設定
End Sub

セル設定

'*************************************************************
'セルに文字を入れる
'*************************************************************

Function CellOption1(AddCellsName As String)

    Cells(1, 1).Value = "ID"
    Cells(1, 2).Value = "氏名"
    Cells(1, 3).Value = "性別"
    Cells(1, 4).Value = "生年月日"
    Cells(1, 5).Value = "郵便番号"
    Cells(1, 6).Value = "住所"
    Cells(1, 7).Value = "電話番号"
    Cells(1, 8).Value = "メール"
    
End Function

'*************************************************************
'セルの幅を変える
'*************************************************************

Function CellOption2(AddCellsWidth As Integer)
    Columns("A").ColumnWidth = 20
    Columns("B").ColumnWidth = 15
    Columns("C").ColumnWidth = 6
    Columns("D").ColumnWidth = 12
    Columns("E").ColumnWidth = 12
    Columns("F").ColumnWidth = 55
    Columns("G").ColumnWidth = 15
    Columns("H").ColumnWidth = 55
End Function

'*************************************************************
'セルの色を変える
'*************************************************************

Function CellOption3(AddCellsColor As Integer)
 Range("A1:H1").Interior.ColorIndex = 4
End Function

'*************************************************************
'セルのフォントを変える
'*************************************************************

Function CellOption4()
  With Range("A1:H1").Font
    .Name = "Meirio UI"
    .Size = 12
    .ColorIndex = 1
    .Bold = True
  End With
End Function

'*************************************************************
'セルに罫線を引く
'*************************************************************

Function CellOption5()
  With Range("A1:H1", Range("A1:H1").End(xlDown).End(xlToRight)).Borders
    .LineStyle = xlDouble
    .Weight = xlThick
    .ColorIndex = 32
  End With
End Function

メニュー画面マクロ設定

'
'＝＝＝＝＝＝＝＝＝＝マクロ登録用モジュール＝＝＝＝＝＝＝＝＝＝

Public flag As Boolean '削除ボタンの表示判定変数

'*************************************************************
'データ入力画面を表示
'*************************************************************

Sub InputDataWindow()
    UserForm1.Show
End Sub

'*************************************************************
'データ検索画面を表示
'*************************************************************

Sub SearchDataWindow()
    flag = 0
    UserForm2.Show
    
End Sub

'*************************************************************
'データ削除画面を表示
'*************************************************************

Sub DeleteDataWindow()
    flag = True
    UserForm2.Show
End Sub

'*************************************************************
'印刷設定画面を表示
'*************************************************************
Sub PrintOptionWindow()
    UserForm3.Show
End Sub


'*************************************************************
'印刷・PDF化画面を表示
'*************************************************************

Sub PrintAndPDFWindow()
    UserForm4.Show
End Sub