VBA 連動したプルダウンを作る ＆ 自動登録
こんにちは。
派犬事務員のコロ子です。
連動したプルダウンリストを作る
ブロック、都道府県、会社名、支店名からできている「店舗情報」シートがある。
この店舗情報を元に、このようなデータを入力したい。
「けっこう入力が大変」と渡された状態ではブロックがプルダウンリストで選択できる。
そして、プルダウンを選択して都道府県を入力しようとすると
選択したブロック以外の都道府県もプルダウンリストに出てしまう。
そして、会社名、支店名はプルダウンリストにするのを諦めたようで手入力になっている。
確かに入力が大変なので「店舗情報」のシートより連動して絞れるプルダウンリストがあるといいかも。
また、店舗情報は随時追加される。
条件としては
①ブロック、都道府県、会社名、支店名がプルダウンリストより選択できるようにする。
②新規の追加ができるようにする。
・プルダウンリスト以外に手入力ができるようにする。
・手入力したデータが「店舗情報」シートに追加される。
では、早速作成してみよう。
コード
【Sheet1(データ)モジュール】
'自動登録用に最初のセルの内容を記憶しておく
Private BeforCompany As String
Private BeforBranch As String
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'1行目はタイトル行なので無視する
If Target.Row = 1 Then
Exit Sub
End If
Dim bloclData As String
'手入力したて出たエラーを無視する
On Error Resume Next
'ブロックの列が選択されたとき
If Target.Column = 2 Then
bloclData = Sheet2.Block()
'プルダウンリストをリセット
Target.Validation.Delete
'リストを追加
Target.Validation.Add Type:=xlValidateList, _
Operator:=xlEqual, _
AlertStyle:=xlValidAlertWarning, _
Formula1:=bloclData
'都道府県の列が選択されたとき
ElseIf Target.Column = 3 Then
'ブロック名が入っているときのみ
If Target.Offset(0, -1).Value <> "" Then
bloclData = Sheet2.Prefectures(Target)
'プルダウンリストをリセット
Target.Validation.Delete
'リストを追加
Target.Validation.Add Type:=xlValidateList, _
Operator:=xlEqual, _
AlertStyle:=xlValidAlertWarning, _
Formula1:=bloclData
End If
'会社名の列が選択されたとき
ElseIf Target.Column = 4 Then
'都道府県名が入っているときのみ
If Target.Offset(0, -1).Value <> "" Then
bloclData = Sheet2.company(Target)
'プルダウンリストをリセット
Target.Validation.Delete
'リストを追加
Target.Validation.Add Type:=xlValidateList, _
Operator:=xlEqual, _
AlertStyle:=xlValidAlertInformation, _
Formula1:=bloclData
End If
'支店名の列が選択されたとき
ElseIf Target.Column = 5 Then
'データ追加の為に記憶しておく
If Target.Value <> "" Then
BeforCompany = Target.Offset(0, -1)
BeforBranch = Target.Value
End If
'都道府県名、会社名が入っているとき
If Target.Offset(0, -1).Value <> "" And Target.Offset(0, -2).Value <> "" Then
bloclData = Sheet2.branch(Target)
'プルダウンリストをリセット
Target.Validation.Delete
'リストを追加
Target.Validation.Add Type:=xlValidateList, _
Operator:=xlEqual, _
AlertStyle:=xlValidAlertInformation, _
Formula1:=bloclData
End If
'数の列が選択されたとき
ElseIf Target.Column = 6 Then
'店舗情報シートにない会社を登録する
If Target.Offset(0, -1).Value <> "" Then
Call Sheet2.Add_Data(BeforCompany, BeforBranch, Target.Row)
End If
End If
End Sub
【Sheet2(店舗情報)モジュール】
Function Block() As String
'ブロック名をカンマ(,)で区切った文字列を返す
Dim dic As Dictionary
Set dic = New Dictionary
Dim str As String
Dim i As Long
For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
'ブロック名の重複を確認する
If dic.Exists(Cells(i, 1).Value) = False Then
dic.Add Cells(i, 1).Value, i
str = str & Cells(i, 1).Value & ","
End If
Next i
If str = "" Then
Block = ""
Else
'最後の,を取る
Block = Left(str, Len(str) - 1)
End If
End Function
Function Prefectures(Target As Range) As String
'件名をカンマ(,)で区切った文字列を返す
Dim dic As Dictionary
Set dic = New Dictionary
Dim str As String
Dim i As Long
For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
'データシートのブロック名と店舗情報のブロック名が同じとき
If Sheet1.Cells(Target.Row, 2).Value = Cells(i, 1).Value Then
'都道府県名の重複を確認する
If dic.Exists(Cells(i, 2).Value) = False Then
dic.Add Cells(i, 2).Value, i
str = str & Cells(i, 2).Value & ","
End If
End If
Next i
If str = "" Then
Prefectures = ""
Else
'最後の,を取る
Prefectures = Left(str, Len(str) - 1)
End If
End Function
Function company(Target As Range) As String
'会社名をカンマ(,)で区切った文字列を返す
Dim dic As Dictionary
Set dic = New Dictionary
Dim str As String
Dim i As Long
For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
'都道府県が同じとき
If Sheet1.Cells(Target.Row, 3).Value = Cells(i, 2).Value Then
'会社名の重複を確認する
If dic.Exists(Cells(i, 3).Value) = False Then
dic.Add Cells(i, 3).Value, i
str = str & Cells(i, 3).Value & ","
End If
End If
Next i
If str = "" Then
company = ""
Else
'最後の,を取る
company = Left(str, Len(str) - 1)
End If
End Function
Function branch(Target As Range) As String
'支店名をカンマ(,)で区切った文字列を返す
Dim dic As Dictionary
Set dic = New Dictionary
Dim str As String
Dim i As Long
For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
'データシートと店舗情報の都道府県と会社名が同じ時
If Sheet1.Cells(Target.Row, 3).Value = Cells(i, 2).Value And _
Sheet1.Cells(Target.Row, 4).Value = Cells(i, 3).Value Then
'支店名の重複を確認する
If dic.Exists(Cells(i, 4).Value) = False Then
dic.Add Cells(i, 4).Value, i
str = str & Cells(i, 4).Value & ","
End If
End If
Next i
If str = "" Then
branch = ""
Else
'最後の,を取る
branch = Left(str, Len(str) - 1)
End If
End Function
Sub Add_Data(company As String, branch As String, r As Long)
Dim flg As Boolean
Dim lastRow As Long
lastRow = Cells(Rows.Count, 1).End(xlUp).Row
Dim i As Long
For i = 2 To lastRow
'会社名と支店名がマッチするものがすでにある場合
If Cells(i, 3).Value = company And _
Cells(i, 4).Value = branch Then
flg = True
Exit For
End If
Next i
If flg Then
'上書き
Cells(i, 1).Value = Sheet1.Cells(r, 2).Value
Cells(i, 2).Value = Sheet1.Cells(r, 3).Value
Cells(i, 3).Value = Sheet1.Cells(r, 4).Value
Cells(i, 4).Value = Sheet1.Cells(r, 5).Value
Else
'最終行に追加
Cells(lastRow + 1, 1).Value = Sheet1.Cells(r, 2).Value
Cells(lastRow + 1, 2).Value = Sheet1.Cells(r, 3).Value
Cells(lastRow + 1, 3).Value = Sheet1.Cells(r, 4).Value
Cells(lastRow + 1, 4).Value = Sheet1.Cells(r, 5).Value
End If
'ソートする
With Me.Sort
.SortFields.Clear
.SortFields.Add Key:=Range("A1"), Order:=xlAscending
.SortFields.Add Key:=Range("B1"), Order:=xlAscending
.SortFields.Add Key:=Range("C1"), Order:=xlAscending
.SortFields.Add Key:=Range("D1"), Order:=xlAscending
.SetRange UsedRange
.Header = xlYes
.Apply
End With
End Sub
Sheet1(データ)モジュールでは
Worksheet_SelectionChange イベントでセルの選択が変更されたらマクロを実行する。ちょっとコードが長くなっちゃったけど、どの列が選択されたかを判定している。
ポイントは
リストを追加するValidation.Addメソッドで
AlertStyle:=xlValidAlertWarning
にするとアラートが出て、手入力できる。
また
On Error Resume Nextステートメントで、手入力したときにプルダウンリストが作成できないエラーをスキップする。
Sheet2(店舗情報)モジュールでデータの重複を排除するためにDictionaryオブジェクトを使用した。AddメソッドでKeyにプルダウンリストにするデータ入れてExistsメソッドで重複を確認する。Itemは必要ないけど省略できなかったので、適当にカウンタ変数iを入れた。
もっと良い方法があるのかもしれないけど、Dictionaryオブジェクトしか思いつかなかったので。
新規登録はデータシートの6列目（数の列）が選択されたとき「店舗情報」シートに店舗名と支店名が同じものがなければデータを追加する。また最初に入っている値をモジュール変数に入れて記憶しておけば、データの変更があった時に上書きをする。
