申請を受けた内容をExcelに転記し、組織名称を入力するなど、人事では様々なタイミングで組織名称を入力する機会があります。
組織名称は会社で決まっているものなので、できれば入力の手間を省きたいですよね！
ということで、今回はExcelの中で組織名称の絞り込みを行うプログラムを紹介します。
組織の絞り込みとは･･･？！
まずはこちらをご覧ください。※BGMありますので、音量ご注意ください。←内容とは関係ないです
OrgシートにDivision・Department・Sectionの三階層の組織情報を記載しています。
このシートの情報より、ListシートのDivision→Sectionまでの入力作業を簡略化しているものです。
わたしの会社では、Division（部門）、Department（部）、Section（課）と分かれていますので、以降、部門/部/課と表現します。（組織名称は(仮)です）
組織情報の入力について
部門名に「管理」と入力すると、Orgシートの部門名より、経営管理部門と生産管理部門の二つの部門がピックアップされます。 入力した文字から部分一致で部門名を抽出し、リストボックスで検索できるようにするというものです。
部門名を選択すると、自動で右の行に遷移します。 そして、当該部門名の中に存在する部名がプルダウンで表示されます。
課名についても同じく、部名に応じて自動的にプルダウン表示となります。便利ですね。
課名まで入力が終わったら、入力済み部門/部/課名より、組織コード/所属長ID・氏名を自動で表示します。
部門名が一致しないケース
部門名称を検索して、一致しないケースも想定しています。 あああああ組織と入力して、Enterを押すと、、
「該当する組織名が存在しません！！」と表示されます。 何かしら一致するような文字を入力して検索してくださいね！
サンプルファイル
以下のファイルをダウンロードして動作をご確認ください。
サンプルコード
ワークシートのイベントプロシージャ
上記サンプルのListシートに記載しているコードです。 このコードで、Orgシートの情報を読み取って、Listシートで絞り込みを行っています。
Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
Dim targetCnt, orgCnt As Long: targetCnt = 0
Dim varidationStr, divStr, depStr, secStr As String: varidationStr = ""
Dim ws, wsOrg As Worksheet
Set ws = ThisWorkbook.Worksheets("List")
Set wsOrg = ThisWorkbook.Worksheets("org")
Dim masterEndRow, iDiv, iDep, iSec As Long
Dim orgArray, hakenStr, orgStr, divArray, depArray, secArray As Variant
' -----------------------------
' 情報取得
' -----------------------------
' orgシートの最下行を取得(A列)
masterEndRow = wsOrg.Cells(Rows.Count, 1).End(xlUp).Row
' 組織情報をすべて配列に格納
orgArray = wsOrg.Range("A2:F" & masterEndRow)
divArray = wsOrg.Range("A2:A" & masterEndRow)
depArray = wsOrg.Range("B2:B" & masterEndRow)
secArray = wsOrg.Range("C2:C" & masterEndRow)
' Listの書き込み列
Const orgCd = "F"
Const bossId = "G"
Const bossNm = "H"
' 複数選択の場合、処理停止
If Target.Count > 1 Then
Exit Sub
End If
' -----------------------------
' Division
' -----------------------------
If Selection.Column = "3" Then
For iDiv = 1 To masterEndRow
orgStr = orgArray(iDiv, 1)
orgCnt = orgCnt + 1
' 入力内容がマスタと完全一致する場合、一つのDivision名でバリデーション設定
If orgStr = Target.Value Then
varidationStr = orgStr
targetCnt = targetCnt + 1
' Division名が一致したら、Department名を入力する
GoTo INPUT_DEP_NAME
' 入力内容がマスタと部分一致する場合、文字列結合し、バリデーション設定
ElseIf orgStr Like "*" & Target.Value & "*" Then
If targetCnt = 0 Then
varidationStr = orgStr
Else
' orgStrが前に出てきた文字列でなければ追加
If findNumber(CStr(varidationStr), CStr(orgStr)) <> 1 Then
varidationStr = varidationStr & "," & orgStr
End If
End If
targetCnt = targetCnt + 1
End If
Next
If targetCnt = 0 Then
Application.EnableEvents = False
Target.Value = "該当する組織名が存在しません！！"
Application.EnableEvents = True
Exit Sub
ElseIf targetCnt = 1 Then
Application.EnableEvents = False
Target.Value = varidationStr
Application.EnableEvents = True
Exit Sub
Else
' リスト設定
With Target.Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertInformation, _
Operator:=xlBetween, Formula1:=varidationStr
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.IMEMode = xlIMEModeNoControl
.ShowInput = True
.ShowError = False
End With
Target.Select
SendKeys "%{DOWN}"
End If
' -----------------------------
' Department
' -----------------------------
ElseIf Selection.Column = "4" Then
For orgCnt = 1 To UBound(divArray)
' DivisionとDepartmentの名前がマスタと完全一致する場合、Sectionをバリデーション設定する
If depArray(orgCnt, 1) = Target.Value And divArray(orgCnt, 1) = Target.Offset(0, -1).Value Then
' Division名/Department名が一致したら、Section名を入力する
GoTo INPUT_SEC_NAME
' 入力内容がマスタと部分一致する場合、文字列結合し、バリデーション設定
ElseIf depArray(orgCnt, 1) Like "*" & Target.Value & "*" And divArray(orgCnt, 1) = Target.Offset(0, -1).Value Then
If targetCnt = 0 Then
varidationStr = depArray(orgCnt, 1)
Else
' orgStrが前に出てきた文字列でなければ追加
If findNumber(CStr(varidationStr), CStr(depArray(orgCnt, 1))) <> 1 Then
varidationStr = varidationStr & "," & depArray(orgCnt, 1)
End If
End If
targetCnt = targetCnt + 1
End If
Next
If targetCnt = 0 Then
Application.EnableEvents = False
Target.Value = "該当する組織名が存在しません！！"
Application.EnableEvents = True
Exit Sub
ElseIf targetCnt = 1 Then
Application.EnableEvents = False
Target.Value = varidationStr
Application.EnableEvents = True
Exit Sub
Else
' リスト設定
With Target.Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertInformation, _
Operator:=xlBetween, Formula1:=varidationStr
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.IMEMode = xlIMEModeNoControl
.ShowInput = True
.ShowError = False
End With
Target.Select
SendKeys "%{DOWN}"
End If
' -----------------------------
' Section入力後、組織コード・所属長ID/氏名入力
' -----------------------------
ElseIf Selection.Column = "5" And Target.Value <> "" Then
' 組織コード
If ws.Range(orgCd & Target.Row).Value = "" Then
ws.Range(orgCd & Target.Row).NumberFormatLocal = "G/標準"
ws.Range(orgCd & Target.Row).Formula = "=XLOOKUP(C" & Target.Row & "&D" & Target.Row & "&E" & Target.Row & ",'Org'!$A:$A&'Org'!$B:$B&'Org'!$C:$C,'Org'!$F:$F)"
ws.Range(orgCd & Target.Row).Value = ws.Range(orgCd & Target.Row).Value
End If
' 所属長ID
If ws.Range(bossId & Target.Row).Value = "" Then
ws.Range(bossId & Target.Row).NumberFormatLocal = "G/標準"
ws.Range(bossId & Target.Row).Formula = "=TEXT(XLOOKUP(C" & Target.Row & "&D" & Target.Row & "&E" & Target.Row & ",'Org'!$A:$A&'Org'!$B:$B&'Org'!$C:$C,'Org'!$D:$D,'Org'!$D:$D),""0000000000"")"
ws.Range(bossId & Target.Row).NumberFormatLocal = "@"
ws.Range(bossId & Target.Row).Value = ws.Range(bossId & Target.Row).Value
End If
' 所属長名
If ws.Range(bossNm & Target.Row).Value = "" Then
ws.Range(bossNm & Target.Row).NumberFormatLocal = "G/標準"
ws.Range(bossNm & Target.Row).Formula = "=XLOOKUP(C" & Target.Row & "&D" & Target.Row & "&E" & Target.Row & ",'Org'!$A:$A&'Org'!$B:$B&'Org'!$C:$C,'Org'!$E:$E)"
ws.Range(bossNm & Target.Row).Value = ws.Range(bossNm & Target.Row).Value
End If
' -----------------------------
' Section入力後、組織コード・所属長ID/氏名入力
' -----------------------------
ElseIf Selection.Column = "6" And Target.Value = "" Then
' 組織コード
If ws.Range(orgCd & Target.Row).Value = "" Then
ws.Range(orgCd & Target.Row).NumberFormatLocal = "G/標準"
ws.Range(orgCd & Target.Row).Formula = "=XLOOKUP(C" & Target.Row & "&D" & Target.Row & "&E" & Target.Row & ",'Org'!$A:$A&'Org'!$B:$B&'Org'!$C:$C,'Org'!$F:$F)"
ws.Range(orgCd & Target.Row).Value = ws.Range(orgCd & Target.Row).Value
End If
' 所属長ID
If ws.Range(bossId & Target.Row).Value = "" Then
ws.Range(bossId & Target.Row).NumberFormatLocal = "G/標準"
ws.Range(bossId & Target.Row).Formula = "=TEXT(XLOOKUP(C" & Target.Row & "&D" & Target.Row & "&E" & Target.Row & ",'Org'!$A:$A&'Org'!$B:$B&'Org'!$C:$C,'Org'!$D:$D,'Org'!$D:$D),""0000000000"")"
ws.Range(bossId & Target.Row).NumberFormatLocal = "@"
ws.Range(bossId & Target.Row).Value = ws.Range(bossId & Target.Row).Value
End If
' 所属長名
If ws.Range(bossNm & Target.Row).Value = "" Then
ws.Range(bossNm & Target.Row).NumberFormatLocal = "G/標準"
ws.Range(bossNm & Target.Row).Formula = "=XLOOKUP(C" & Target.Row & "&D" & Target.Row & "&E" & Target.Row & ",'Org'!$A:$A&'Org'!$B:$B&'Org'!$C:$C,'Org'!$E:$E)"
ws.Range(bossNm & Target.Row).Value = ws.Range(bossNm & Target.Row).Value
End If
End If
Exit Sub
INPUT_DEP_NAME:
' Departmentのバリデーション設定
For orgCnt = 1 To UBound(divArray)
' Division名の情報と一致するDepartmentを表示する
If divArray(orgCnt, 1) = varidationStr And IsEmpty(depArray(orgCnt, 1)) = False Then
' orgStrが前に出てきた文字列でなければ追加
If depStr = "" Then
depStr = depArray(orgCnt, 1)
ElseIf findNumber(CStr(depStr), CStr(depArray(orgCnt, 1))) <> 1 Then
depStr = depStr & "," & depArray(orgCnt, 1)
End If
targetCnt = targetCnt + 1
End If
' Division名の情報と一致し、かつ、Department名がブランクのSection名を表示する
If divArray(orgCnt, 1) = varidationStr And IsEmpty(depArray(orgCnt, 1)) = True And IsEmpty(secArray(orgCnt, 1)) = False Then
' orgStrが前に出てきた文字列でなければ追加
If secStr = "" Then
secStr = secArray(orgCnt, 1)
ElseIf findNumber(CStr(secStr), CStr(secArray(orgCnt, 1))) <> 1 Then
secStr = secStr & "," & secArray(orgCnt, 1)
End If
End If
Next
If targetCnt = 0 Then
Application.EnableEvents = False
Target.Value = "該当する組織名が存在しません！！"
Application.EnableEvents = True
Exit Sub
Else
' リスト設定
With Target.Offset(0, 1).Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertInformation, _
Operator:=xlBetween, Formula1:=depStr
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.IMEMode = xlIMEModeNoControl
.ShowInput = True
.ShowError = False
End With
' リスト設定
With Target.Offset(0, 2).Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertInformation, _
Operator:=xlBetween, Formula1:=secStr
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.IMEMode = xlIMEModeNoControl
.ShowInput = True
.ShowError = False
End With
Target.Offset(0, 1).Select
SendKeys "%{DOWN}"
End If
Exit Sub
INPUT_SEC_NAME:
' Section名のバリデーション設定
For orgCnt = 1 To UBound(divArray)
' Division名・Department名の情報が一致した場合、Section名をバリデーション設定する
If depArray(orgCnt, 1) = Target.Value And divArray(orgCnt, 1) = Target.Offset(0, -1).Value Then
' orgStrが前に出てきた文字列でなければ追加
If secStr = "" Then
secStr = secArray(orgCnt, 1)
ElseIf findNumber(CStr(secStr), CStr(secArray(orgCnt, 1))) <> 1 Then
secStr = secStr & "," & secArray(orgCnt, 1)
End If
targetCnt = targetCnt + 1
End If
Next
If targetCnt = 0 Then
Application.EnableEvents = False
Target.Offset(0, 1).Value = "該当する組織名が存在しません！！"
Application.EnableEvents = True
Exit Sub
Else
' リスト設定
With Target.Offset(0, 1).Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertInformation, _
Operator:=xlBetween, Formula1:=secStr
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.IMEMode = xlIMEModeNoControl
.ShowInput = True
.ShowError = False
End With
Target.Offset(0, 1).Select
SendKeys "%{DOWN}"
End If
Exit Sub
End Sub
Functionプロシージャ
上記コードの中で、利用しているFunctionプロシージャについて、標準モジュールを追加して以下のコードを記載しています。
' ****************************************
' 文字列の中に指定の文字が何回出てくるか
' string1:検索元の文字列
' string2:検索対象文字列
' 例：findnumber("AAA","A") → 3
' ****************************************
Function findNumber(string1 As String, string2 As String)
Dim N As Long, cnt As Long
N = InStr(1, string1, string2)
Do While N > 0
cnt = cnt + 1
N = InStr(N + 1, string1, string2)
Loop
findNumber = cnt
End Function
さいごに
組織名称の絞り込みができるようになれば、一段階上の管理表になる気がしますよね。 ぜひご活用ください！
