グループ毎に入力規則作成(ExcelVBA)

ゆーしゃん
2022.01.30
156 views

概要

リストに基づいて、
A列「通常_会社名」がセル結合されている場合、結合行の
B列「正式_会社名」文言全てを
「データの入力規則」に設定する

※入力規則作成イメージ)
A列「通常_会社名」が
「A」の場合：入力規則を「(株)A,(株)B」
「D」の場合：入力規則を「(株)D,(株)α,(株)β,(株)γ」
と設定

プログラムを作成した理由

工場勤務時にて、
「生産した商品の上に納品書を添える」
という工程がありました。

その納品書に「会社名」を選択する項目があったのですが…

↓のように全会社名が入力規則として設定されている為、
目的の会社名を探すのに2、3分かかっておりました。

※全部で数百社以上登録されており、
スクロールの下の方に埋もれている会社名を探そうとするのが面倒すぎました…(泣)

この納品書を私含む5人のメンバーが、
各自1日10枚以上印刷する必要があった為…

メンバー数(5人) × 会社名を探す(2分) × 印刷回数(10回) = 約100分
も、会社名選択だけで時間が掛かっている事に気が付きました。

工場の社員は「プログラムによる自動化」というのは範疇に無いはずですが、
私の事を可愛がってくれていた先輩社員に

「皆さんが呼称する通称会社名を記載したら、関連会社のみがリストに表示される…
となっていたらどう思いますか？選択しやすいでしょうか？」

と、プログラムによる改善案を提案したところ、

「面白そうじゃん！お前にしか出来ないんだからやってみろ！」と
力強く背中を押してくれた為、実装に踏み切れました。

ソースコード

'共有定数
Const 納品書_シート名 As String = "納品書"
Const 納品先リスト_シート名 As String = "納品先リスト"

Const 納品書_通称会社名_セル位置 As String = "C4"
Const 納品書_正式会社名_セル位置 As String = "C5"
Const 納品先リスト_略称会社名_列位置 As Integer = 1

'共有変数
Dim 納品書_シート As Worksheet
Dim 納品先リスト_シート As Worksheet

Sub 実行()
    
    '変数定義
    Dim Search_Word As String
    Dim Result_List As String

    'シート設定
    Set 納品書_シート = Worksheets(納品書_シート名)
    Set 納品先リスト_シート = Worksheets(納品先リスト_シート名)
    
    '初期化
    Search_Word = ""
    Result_List = ""
    
    With 納品書_シート
        
        '検索ワード取得
        Search_Word = .Range(納品書_通称会社名_セル位置).Value
        
        '未入力チェック
        If Search_Word = "" Then
            MsgBox "会社名を入力してから実行してください。"
            Exit Sub
        End If
        
        '正式_会社名初期化
        .Range(納品書_正式会社名_セル位置).ClearContents
        
        '文言取得
        Result_List = セル結合範囲_文言取得(Search_Word)
        
        '文言空白チェック
        If Result_List = "" Then
        
            '存在しない場合は中止
            MsgBox "「" & Search_Word & "」はリストに存在しておりません。"
            
            '検索した会社名を初期化
            .Range(納品書_通称会社名_セル位置).ClearContents
            
            Exit Sub
        
        End If
        
        '取得した文言で入力規則設定
        Call 入力規則設定(Result_List)
    
    End With

    '完了メッセージ
    MsgBox "入力規則を作成致しました！"
    
End Sub

'参考：https://www.sejuku.net/blog/28929
Function セル結合範囲_文言取得(Search_Word As String) As String
    
    '変数定義
    Dim buf As String
    Dim c As Variant
    Dim End_Row As Long
    
    'ループカウンタ
    Dim i As Long
    
    '初期化
    buf = ""
    
    With 納品先リスト_シート
    
        '最終行取得
        End_Row = .Cells(Rows.Count, 1).End(xlUp).Row
        
        '2行目から最終行までループ
        For i = 2 To End_Row
            
            '検索ワードと一致した場合
            If .Cells(i, 納品先リスト_略称会社名_列位置).Value = Search_Word Then
                
                'セル結合されている範囲の文言取得
                For Each c In .Cells(i, 納品先リスト_略称会社名_列位置).MergeArea
                    buf = buf & c.Offset(0, 1) & ","
                Next c
                
                '必ず結合されてしまう、末尾カンマを除外
                buf = Left(buf, Len(buf) - 1)
                
                'ループ終了して返却値設定し、処理終了
                Exit For
                
            End If
            
        Next i
    
    End With
    
    '返却値
    セル結合範囲_文言取得 = buf
    
End Function

'参考：https://www.moug.net/tech/exvba/0050121.html
Sub 入力規則設定(set_list As String)
    
    With 納品書_シート

        With .Range(納品書_正式会社名_セル位置).Validation
        
            .Delete
            .Add Type:=xlValidateList, _
                 Operator:=xlEqual, _
                 Formula1:=set_list
                 
        End With
        
        'フォーカスを移動
        .Range(納品書_正式会社名_セル位置).Select
    
    End With
        
End Sub

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

121

122

123

124

125

126

127

128

129

130

131

132

133

'共有定数

Const 納品書_シート名 As String = "納品書"

Const 納品先リスト_シート名 As String = "納品先リスト"

Const 納品書_通称会社名_セル位置 As String = "C4"

Const 納品書_正式会社名_セル位置 As String = "C5"

Const 納品先リスト_略称会社名_列位置 As Integer = 1

'共有変数

Dim 納品書_シート As Worksheet

Dim 納品先リスト_シート As Worksheet

Sub 実行()

'変数定義

Dim Search_Word As String

Dim Result_List As String

'シート設定

Set 納品書_シート = Worksheets(納品書_シート名)

Set 納品先リスト_シート = Worksheets(納品先リスト_シート名)

'初期化

Search_Word = ""

Result_List = ""

With 納品書_シート

'検索ワード取得

Search_Word = .Range(納品書_通称会社名_セル位置).Value

'未入力チェック

If Search_Word = "" Then

MsgBox "会社名を入力してから実行してください。"

Exit Sub

End If

'正式_会社名初期化

.Range(納品書_正式会社名_セル位置).ClearContents

'文言取得

Result_List = セル結合範囲_文言取得(Search_Word)

'文言空白チェック

If Result_List = "" Then

'存在しない場合は中止

MsgBox "「" & Search_Word & "」はリストに存在しておりません。"

'検索した会社名を初期化

.Range(納品書_通称会社名_セル位置).ClearContents

Exit Sub

End If

'取得した文言で入力規則設定

Call 入力規則設定(Result_List)

End With

'完了メッセージ

MsgBox "入力規則を作成致しました！"

End Sub

'参考：https://www.sejuku.net/blog/28929

Function セル結合範囲_文言取得(Search_Word As String) As String

'変数定義

Dim buf As String

Dim c As Variant

Dim End_Row As Long

'ループカウンタ

Dim i As Long

'初期化

buf = ""

With 納品先リスト_シート

'最終行取得

End_Row = .Cells(Rows.Count, 1).End(xlUp).Row

'2行目から最終行までループ

For i = 2 To End_Row

'検索ワードと一致した場合

If .Cells(i, 納品先リスト_略称会社名_列位置).Value = Search_Word Then

'セル結合されている範囲の文言取得

For Each c In .Cells(i, 納品先リスト_略称会社名_列位置).MergeArea

buf = buf & c.Offset(0, 1) & ","

Next c

'必ず結合されてしまう、末尾カンマを除外

buf = Left(buf, Len(buf) - 1)

'ループ終了して返却値設定し、処理終了

Exit For

End If

Next i

End With

'返却値

セル結合範囲_文言取得 = buf

End Function

'参考：https://www.moug.net/tech/exvba/0050121.html

Sub 入力規則設定(set_list As String)

With 納品書_シート

With .Range(納品書_正式会社名_セル位置).Validation

.Delete

.Add Type:=xlValidateList, _

Operator:=xlEqual, _

Formula1:=set_list

End With

'フォーカスを移動

.Range(納品書_正式会社名_セル位置).Select

End With

End Sub

導入&実行方法

実際にマクロを動かしたい方、ツールを見たい方は
以下からダウンロードして実行してみて下さい。

納品書_入力規則作成ダウンロード

ダウンロードしたツールのプロパティを開く

「セキュリティ」の「許可する」にチェックし、
「適応」「OK」ボタンを押す

この作業を行う事でツールが動くようになります。

実際にツールを開き、
「納品先リスト」シートA列「通称_会社名」に存在する会社名を
B4セルに入力し、「会社名検索」ボタンを押す

B5セルに入力規則が生成されている事を確認し、会社名を手動で選択する。

感想

本プログラム作成後は
~~メンバー数(5人) × 会社名を探す(2分) × 印刷回数(10回) = 約100分~~
メンバー数(5人) × 会社名を探す(5秒) × 印刷回数(10回) = 約1分
と大幅に作業時間が削減されました！

数ヵ月毎の「社員提案&実行における業務改善発表会」にて、
本プログラムが発表され、ボーナス1000円程頂きました！

…が、ボーナスよりも
先輩社員や、プログラムを用いた自動化の噂を聞いた他部署の部長が、
度々ラーメン奢ってくれた事の方が嬉しかったです(笑)

「プログラマーとして上手くいかなかったから、スキル不要な工場でいいや」
と適当に決めた工場勤務でしたが、

「私の拙いプログラムでも役に立てる！」
と自信を持つキッカケとなった1件でした。

※今振り返ると、この経験が人生のターニングポイントになったと思います。

編集履歴

2021/01/30　新規作成

グループ毎に入力規則作成(ExcelVBA)

概要

プログラムを作成した理由

ソースコード

導入&実行方法

感想

編集履歴

関連記事一覧

CSV分割マクロ(ExcelVBA)

数式リンク切れチェック(ExcelVBA)

Excelアドイン(マクロ)をリボンに登録(ExcelVBA)

特定記号を基に末尾から文字数調整(ExcelVBA)

環境依存文字チェック(ExcelVBA)

【Twitter_bot】検索ワードでの「いいね」昇順ツイート(Python)

Slack_タスク管理bot(Python)

CSV分割マクロ(ExcelVBA)

チェックボックス選択肢に基くフィールド活性/非活性/必須化(kintone×JavaScript)

YouTube動画/音声のダウンロード(Python)

スプレッドシートをExcel形式でDL(Python)

CSV分割マクロ(ExcelVBA)

Slack_タスク管理bot(Python)

環境依存文字チェック(ExcelVBA)