業務効率化

コンボボックスからシート上の項目と小項目を動的選択

シート上に記載された項目と、それに対する複数の小項目をコンボボックスで表示されるマクロです。項目×小項目の選択に基づいて値を取得でき、マクロの実行やファイル、フォルダを開くなどの複数の処理を直感的にもできるようになります。VBAによるOutlookメール作成システムで紹介したUFの紹介です。記事:https://gakuhenn.com/vba-chatgptapi-outlookmail-system/

記事の内容

・挙動

・コード

・ポイント機能、応用

挙動

コード

➤コードはこちら 
Option Explicit

Public mailuf As Object
Public Selectcnt As Long 'ユーザﾌｫｰﾑ項目選択時のカウント変数

Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
Private Declare PtrSafe Function SetWindowPos Lib "user32" (ByVal hWnd As LongPtr, ByVal hWndInsertAfter As LongPtr, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
 
Const HWND_TOPMOST As Long = -1
Const SWP_NOSIZE As Long = 1
Const SWP_NOMOVE As Long = 2



Private Sub ComboBox1_Change()

End Sub

Private Sub ComboBox2_Enter()
    Static initialized As Boolean:
    If initialized Then
        If Me.ComboBox2.ListCount > 0 Then
            Me.ComboBox2.DropDown
        End If
    Else
        initialized = True
    End If
End Sub

Private Sub ComboBox3_Enter()
    If Me.ComboBox3.ListCount > 0 Then
        Me.ComboBox3.DropDown
    End If
End Sub

Private Sub ComboBox2_Change()

Selectcnt = Selectcnt + 1
If Selectcnt > 1 Then ComboBox3.Clear

Dim pnt As Long, 項目 As Variant
Dim frws As Worksheet: Set frws = ThisWorkbook.Worksheets(1)
Dim cnt As Long, 項目cnt As Long

pnt = WorksheetFunction.match(ComboBox2.value, frws.Range("B:B"), 0)


項目 = frws.Cells(pnt, 3).value
項目 = Replace(項目, "、", ",", , , vbTextCompare)
項目 = Replace(項目, " ", "", , , vbTextCompare)

If InStr(項目, ",") <> 0 Then

'コンマの数を数える　開始位置と終了位置用
'Do While InStr(項目, ",") = 0
 'cnt = cnt + 1
 '項目 = mid( 項目,instr(項目,",")
cnt = (Len(LCase(項目)) - Len(Replace(LCase(項目), LCase(","), ""))) / Len(",")
'MsgBox cnt

    For 項目cnt = 1 To cnt + 1
        
        If InStr(項目, ",") = 0 Then
          ComboBox3.AddItem 項目
          ComboBox3.Font.Size = 11
          Exit For
        Else
          ComboBox3.AddItem Left(項目, InStr(項目, ",") - 1)
          ComboBox3.Font.Size = 11
          項目 = Mid(項目, InStr(項目, ",") + 1)
        End If
        
    Next

ElseIf InStr(項目, ",") = 0 Then
    
    ComboBox3.AddItem 項目
    ComboBox3.Font.Size = 11
    
End If

    ComboBox3.value = ComboBox3.List(0)

End Sub



Sub Closeclassanduf()

'隠れたフォームをすべて閉じる
 Dim frm As Object
    ' UserFormsコレクションをループ
    For Each frm In VBA.UserForms
        Unload frm ' フォームを閉じる
    Next frm
End Sub


Private Sub TextBox2_Change()
If ComboBox2.value Then
TextBox2.Visible = True
Else
ComboBox2.Visible = False
End If


End Sub

Private Sub customer_Click()

End Sub


Private Sub UserForm_Activate()

DoEvents ' フォーム描画をここで一旦完了させる
    If Me.ComboBox2.ListCount > 0 Then
        Me.ComboBox2.DropDown
    End If

End Sub


Private Sub UserForm_Initialize()

    Dim hWnd As LongPtr
 
    '最前面に表示するｳｨﾝﾄﾞｳのﾊﾝﾄﾞﾙを取得(UserForm)
    hWnd = FindWindow(vbNullString, Me.Caption)
 
    'ｳｨﾝﾄﾞｳを常に最前面に配置
    Call SetWindowPos(hWnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOSIZE Or SWP_NOMOVE)
  
  
Dim pnt As Long, i As Long

pnt = ThisWorkbook.Worksheets(1).Range("B" & ThisWorkbook.Worksheets(1).Rows.count).End(xlUp).Row
For i = 2 To pnt
ComboBox2.AddItem ThisWorkbook.Worksheets(1).Cells(i, 2).value
ComboBox2.Font.Size = 11
Next

ComboBox2.value = ComboBox2.List(0)

End Sub
コンボボックスからシート上の項目と小項目を動的選択ダウンロード

ワークシート1のBC列に内容と項目列を作成し、表示させたい値を追加してください。項目はコンマか、で一つの項目を区切ってください。

ポイント機能

・シート上の項目とそれに対する小項目の表示

・ドロップダウンリスト選択の簡素化

シート上の項目とそれに対する小項目の表示

シート上の表B,C列が項目と、小項目の箇所です。UFはInitializeの際にB列の項目を取得し、UF大項目を選択した値を元にシート上のC列にある小項目複数をリストとして表示させます。

例えば大項目を登録された言語にします。

そうすると小項目が、言語に対して設定したC列の値がリストとして表示されます。

ドロップダウンリスト選択の簡素化

UFを開いた際には、大項目のドロップダウンを自動で開き、一つ目の項目を表維持させます。また、小項目もその値を元にしてリスト化して最初の項目を表示させます。

開いた際に大項目ドロップダウンがONになる

ActivateにてDropdownメソッドを実施させています。Initializeにするとうまく発火しないためです。

また、ドロップダウンリストはボックスを選択するだけでも表示可能です。リストのマークを推すのは少しめんどくさいため、白いテキストボックスを選択するだけで出るようにしています。

テキストボックスを選択した際にはEnterのイベントが発火します。これを利用し、選択された場合にドロップダウンを表示させることができます。

UFの活用方法

小項目で得た値に対して何か処理や値を得たい場合があります。その際は下記関数を使用し、応用できます。標準モジュールに一つ目の関数を記載し、さらにUFのコマンドボタンに2つ目を入力して下さい。引数に抜き出したい行タイトル:鳴き声を指定することでそこから値を取得します。

➤ExtraVals関数:UFの取得結果を活用する関数 
Option Explicit

Function ExtractVals(frws As Worksheet, pnt As Long, currentindex As Long, nextindex As Long, ComboBox3 As Object, item As String) As String
    Dim 開始 As Long, 終了 As Long
    Dim j As Long
    Dim extractedText As String

    ' シートから引数itemに入った指定項目の列を取得
    For j = 1 To 10
        If ThisWorkbook.Worksheets(1).Cells(1, j).value Like item Then
            'item = j
            Exit For
        End If
    Next
    
    '件名と補文のセルにCombobox3の値が無い場合は件名が複数項目に共通と見なす
    '項目が多いが夫々が共通の場合の処理
    
    If InStr(1, frws.Cells(pnt, j), ComboBox3.value, vbTextCompare) < 1 Then
        ExtractVals = frws.Cells(pnt, j)
        Exit Function
    End If
    
    
    ' currentindex と nextindex が同じならば
    If currentindex = nextindex Then
        ' 開始位置を決定
        開始 = InStr(1, frws.Cells(pnt, j), ComboBox3.value, vbTextCompare) + Len(ComboBox3.value)
        ' 文字列を抜き出し
        extractedText = Mid(frws.Cells(pnt, j), 開始)
       
    Else
        ' 開始位置を決定
        開始 = InStr(1, frws.Cells(pnt, j), ComboBox3.value, vbTextCompare) + Len(ComboBox3.value)
        
        ' 終了位置を決定
        終了 = InStr(1, frws.Cells(pnt, j), ComboBox3.List(nextindex))
        
        If 終了 > 0 Then
            ' 終了位置から開始位置までの文字列を抜き出し
            extractedText = Mid(frws.Cells(pnt, j), 開始, 終了 - 開始)
        Else
            ' nextindex が範囲外の場合は最後まで
            extractedText = Mid(frws.Cells(pnt, j), 開始)
        End If
    End If

    ' 改行コードと余分な空白を取り除く
    'extractedText = Replace(extractedText, vbCrLf, "") ' 改行コードを削除
    'extractedText = Replace(extractedText, vbCr, "")   ' キャリッジリターンを削除
    'extractedText = Trim(extractedText)                ' 余分な空白を削除

    ' 抽出結果を返す
    ExtractVals = extractedText
    
    
End Function
➤コマンドボタンから呼び出すプロンプト 

Private Sub CommandButton1_Click()
  

Dim frws As Worksheet, pnt As Long, currentindex As Long, nextindex As Long
Dim vals As String

Set frws = ThisWorkbook.Worksheets("項目小項目")

pnt = WorksheetFunction.match(ComboBox2.value, frws.Range("B:B"), 0)

'選択中リストボックスの次の文字検索用に取得
currentindex = ComboBox3.ListIndex

If currentindex >= 0 Then
    ' 現在が最後のアイテムの場合、そのまま
    If currentindex + 1 = ComboBox3.ListCount Then
        nextindex = currentindex ' 最大インデックスの場合、そのまま
    Else
        nextindex = currentindex + 1 ' 次のインデックス
    End If
End If
    
'関数で指定Itemの列取得し、現在IndexとNextIndexから間にある文を抽出
'変数は他のSubと被る可能性ある為、一応括弧代入、Itemだけ指定する
vals = ExtractVals(frws, pnt, currentindex, nextindex, ComboBox3, "鳴き声")
 
 
MsgBox vals


End Sub

関数はUFで得た値を元に活用する関数です。例えばD列にそれぞれの小項目に対する鳴き声があるとします。小項目で①を選ぶと、ワンを取得できます。

-業務効率化