「追加したはずの右クリックメニューが表示されない事件」の真相 ③

Excel VBA 事件簿 試してみた

先日来、２年越しの事件が解決しそうだ。
infoment.hatenablog.com
今日も、先日の続きから。
f:id:Infoment:20200801184556p:plain

右クリックメニューを追加する際、他のマクロで追加された別メニューの有無に関わらず、今までは毎回バツンとリセットしていた。

Sub Test()
    Dim LoopIndex As Variant
        For Each LoopIndex In Array(38, 41, 61, 74, 75)
            With Application.CommandBars(LoopIndex)
                .Reset
                .Controls.Add.Caption = "テスト"
            End With
        Next
End Sub

こうしておかないと、追加するたびにドンドンと増えてしまう。
　
f:id:Infoment:20200801185137p:plain

しかしそれでは、余りに乱暴が過ぎると思っていた。
そこで今回、設定済み右クリックメニューの情報取得と、ピンポイント削除に挑戦してみた。まず、このように設定しておく。
　
f:id:Infoment:20200801185641p:plain

次いでこの中から、「テスト3」だけを消してみよう。

Sub Test2()
    Dim LoopIndex As Variant
    Dim CommandBar As CommandBar
    Dim i As Long
        For Each LoopIndex In Array(38, 41, 61, 74, 75)
            With Application.CommandBars(LoopIndex)
                ' 右クリックメニューを消すたびに段違いが発生する。
                ' 対策として、後ろから削除する。
                For i = .Controls.Count To 1 Step -1
                    If .Controls.Item(i).Caption = "テスト3" Then
                        .Controls.Item(i).Delete
                    End If
                Next
            End With
        Next
End Sub

結果、テスト３だけを消すことが出来た。
　
f:id:Infoment:20200801221742p:plain

これを応用すれば、追加時は事前に追加済みか否かを確認できるし、終了時も目的のメニューだけを消すことが出来そうだ。

次回に続きます（あと１回か、多くても２回）

参考まで。

「追加したはずの右クリックメニューが表示されない事件」の真相 ②

Excel VBA 事件簿 試してみた

先日来、２年越しの事件が解決しそうだ。
infoment.hatenablog.com

今日は、先日の続きから。
f:id:Infoment:20200729215012p:plain

個人的に、追加した右クリックメニューを実行したくなるのは、以下のパターンのとき。

  1. テーブル上のセル又は範囲
  2. ピボットテーブル上のセル又は範囲
  3. 上記以外のセル又は範囲

そこで、先日無理矢理追加した右クリックメニューから、各ビューの上記それぞれについて何が登録されているかを確認してみた。

結果は、下表のとおり。
f:id:Infoment:20200729220644p:plain

PivotTableは全ビュー共通なのに、RangeとTable（＝ListObject）は、改ページプレビューだけ違う。何だか、一貫性が無いように見えて気持ち悪いが（仕様だから）仕方ない。

ところで２年前は、CommandBars("Cell") のように名前で指定した。
今回は、38や61などの番号で登録できないか試してみよう。

Sub Test()
    With Application.CommandBars.Item(38).Controls.Add
        .Caption = "テスト"
    End With
End Sub

↓ できた。
f:id:Infoment:20200729221342p:plain

それでは、これをループさせてみよう。

Sub Test()
    Dim LoopIndex As Variant
        For Each LoopIndex In Array(38, 41, 61, 74, 75)
            With Application.CommandBars(LoopIndex).Controls.Add
                .Caption = "テスト"
            End With
        Next
End Sub

結果、ビューに関係なくテーブルでもピボットテーブルでも、右クリックメニューを表示させることが出来た。

次回に続きます。

参考まで。

「追加したはずの右クリックメニューが表示されない事件」の真相 ①

Excel VBA 事件簿

約２年前、このような記事を作成した。
infoment.hatenablog.com

右クリックメニューに追加したはずのコマンドが表示されない。
でもそれは、改ページプレビューで見たのが原因。そんな感じで
締めくくられている。

しかし実際はそうではないことを、先日職場で教えてもらった。
f:id:Infoment:20200727221003p:plain

当時のメニュー追加マクロは、下記のとおり。

Sub AddNewMenu(new_caption As String, new_action As String)
    Dim NewMenu As CommandBarButton
        Set NewMenu = Application.CommandBars("Cell").Controls.Add()
            With NewMenu
                .Caption = new_caption
                .OnAction = new_action
                .BeginGroup = False
            End With
End Sub

Sub AddMenuTest()
    Application.CommandBars("Cell").Reset
    Call AddNewMenu("追加メニュー", "追加メニュー")
End Sub

今ならわかる。CommandBarsとはつまり、CommandBarがたくさん集まったもの。
従って、CommandBarsコレクションのうち、「Cell」に対してのみメニューを追加していた訳だ。そこで試しに、かなり乱暴ではあるがこんなコードを書いてみた。

Sub Test()
    Dim CommandBar As CommandBar
        On Error Resume Next
        For Each CommandBar In Application.CommandBars
            CommandBar.Reset
            With CommandBar.Controls.Add
                .Caption = CommandBar.Index & "：" & CommandBar.Name
            End With
        Next
End Sub

　
すると、Cellが複数あることが分かる。

  • 標準ビューの場合

f:id:Infoment:20200727222709p:plain

  • ページレイアウトビューの場合

f:id:Infoment:20200727222803p:plain

  • 改ページプレビューの場合

f:id:Infoment:20200727222916p:plain

38番と41番の「Cell」は、どちらも同じ名前なので、名前で指定した結果、38番（＝標準およびページレイアウトビュー）のみに右クリックメニューが追加されていたらしい。

何か、だんだんわかってきた。

次回に続きます。

参考まで。

最初の作りが甘いと、後々まで祟るというお話

Excel VBA クラスモジュール 雑感

１年前作成した ↓ こちら。
infoment.hatenablog.com

改築・増築を繰り返した結果、考え方の不一致などが多数生じていた。
そこで今回、数日かけて全て再構築してみた。
f:id:Infoment:20200723171347p:plain

再構築したクラスモジュール全文は、上記リンク先に反映済みだ。
更に今回は、配列に新たなレコード行を追加できるよう、機能拡張してみた。

例えば、 ↓ の表について。
f:id:Infoment:20200723171800p:plain

この表に、

  • No. 　4
  • 品名　ぶどう
  • 単価　250

の一行を追加し、新たなシートを作成して「編集後」という名前をつけ、
そのシートに編集後の配列を張り付けたうえでテーブル化し、さらに
書式を整えてみよう。

↓ サンプルがこちら。

Sub ArrayTest()
    Dim arr As Variant
        arr = Array(4, "ぶどう", 250)
        
        With New VBAProject.ArrayEdit
            ' 編集前配列。
            .source_array = Range("A1:C4")
            ' 編集前配列に、上記arrを最終レコードとして追加。
            .RowAdd arr, , cpInsert
            ' 上記編集後配列を、新たに作成した「編集後」シートに
            ' テーブルとして貼り付け。
            .PasteArray sheet_name:="編集後", _
                        paste_type:=ptTable, _
                        column_autofit:=True, _
                        select_array:=case_edited
        End With
End Sub

結果、無事にテーブルを作成できた。
f:id:Infoment:20200723172123p:plain

今回の再構築で、一番苦労したところ。それは、再構築の前後で互換性を完全に
保つこと。最初の作りが甘いと、後々まで祟ります（自戒の句）。

参考まで。

ひっくり返して、もう一回ひっくり返す

Excel VBA 雑感

世の中には、頭のいい人が居るもんだ。というお話。
f:id:Infoment:20200722221107p:plain

例えばこのような、５行３列の二次元配列があるとする。
f:id:Infoment:20200722221204p:plain

配列のサイズを変更（Redim）する場合、最大次元のみ変更可能だ。
従って、上記の例に於いては、このようになる。
f:id:Infoment:20200722221511p:plain

二次元配列に於いては、これをテーブルに見立て、レコードを追加するイメージで一次元のサイズを変更したくなる場面が多々ある。しかし、変更できない。そこで昔はいつも、サイズ変更後の配列を別に準備し、そちらに引っ越すという、非常に面倒な手段をとっていた。
f:id:Infoment:20200722222130p:plain

ところがその後、このような方法があることを知った。
まず、Transpose関数で行と列を入れ替える。
f:id:Infoment:20200722222402p:plain

次いで、最大次元のサイズを一つ増やす。
f:id:Infoment:20200722222518p:plain

最後に、もう一度行と列を入れ替える。
f:id:Infoment:20200722222615p:plain

これで、一次元のサイズが変更できてしまった。
コードにするなら、こんな感じだろうか。

Sub ArrayTest()
    ' ５行３列の範囲を、配列として変数arrに格納。
    Dim arr As Variant
        arr = Range("A1:C5")
    ' arrの行列を反転させた配列を、TempArrayに格納。
    Dim TempArray As Variant
        TempArray = WorksheetFunction.Transpose(arr)
    ' TempArrayの二次元サイズを５から６に変更。
    ReDim Preserve TempArray(1 To 3, 1 To 6)
    ' TempArrayの行列を反転させた配列を、arrに格納。
        arr = WorksheetFunction.Transpose(TempArray)
End Sub

結果、希望通りのサイズ変更が出来た。
f:id:Infoment:20200722223159p:plain

初めてこれを目にしたとき、その鮮やかさに感動した。
まさに、コロンブスの卵とはこのこと。種明かしされれば何ということもないが、思いつくのは至難の業。

当たり前の話ですが世の中には、到底かなわないほど頭のいい人がたくさんいる
ものだと、改めて思った次第です。

参考まで。

配列の重複削除 ④ 重複の無い一次元配列を作成するクラスモジュール

Excel VBA 作ってみた クラスモジュール

先日来、二次元配列の任意の一列から、重複の無い一次元配列作成を試みている。
infoment.hatenablog.com

今日は最終回。以前作成したクラスモジュールに、先日作成したユーザー定義関数を含めてみる。
f:id:Infoment:20200719092452p:plain

今回行ったのは、以下の三つ。

  • 以前作成したクラスモジュール「Seaquence」に、今回のユーザー定義関数を
    含めてみる。
  • 配列の次元数取得は同クラスモジュール内に実装済みのため、今回の関数から除外する。
  • 「空白は除去する」など、細かい調整を行う。

それでは今回行った編集の内、関係する部分だけを紹介する。

クラスモジュール（Seaquence）
'   配列の次元数取得
Private Function GetArrayDimension(arr As Variant) As Long
    
    If IsArray(arr) = False Then
        GetArrayDimension = -1
        Exit Function
    End If
    
    ' 配列の次元数を取得。
    
    Dim i As Long
    Dim TempNumber As Long
        
        On Error Resume Next
        Do While Err.Number = 0
            i = i + 1
            TempNumber = UBound(arr, i)
        Loop
        
        GetArrayDimension = i - 1

End Function

' 配列、範囲、テーブルから重複の無い一次元配列を作成。
Function RemovalDuplicateArray(ByVal source As Variant, _
                      Optional ByVal target_column_index As Variant = 1) As Variant
                      
    ' 配列確認。
    Dim source_array As Variant

    ' 配列に格納できないものがセットされる場合を想定し、一時的にエラーを無視。
        On Error Resume Next
        
    ' sourceを範囲で指定された場合。
        If TypeName(source) = "Range" Then
        ' 列番号がアルファベットで指定された場合、数値に変換する。
            If IsNumeric(target_column_index) = False Then
                target_column_index = StrConv(target_column_index, vbNarrow + vbUpperCase)
                If target_column_index Like "*[A-Z]*" Then
                    target_column_index = Cells(1, target_column_index).Column
                End If
                source_array = source.Value
            End If
        
    ' sourceがテーブルの場合。
        ElseIf TypeName(source) = "ListObject" Then
            source_array = source.DataBodyRange.Value
        ' 列がラベル名で指定されている場合、列番号に置き換える。
            If IsNumeric(target_column_index) = False Then
                target_column_index = source.ListColumns(target_column_index).index
            End If
            
    ' sourceが配列の場合。
        ElseIf IsArray(source) Then
            source_array = source

    ' sourceが上記以外の場合（例えば文字列などの場合）。
        Else
            source_array = Array(source)
        End If
    
    ' 上記でエラーが発生していた場合の処理。
        If Err.Number <> 0 Then
            GoTo er:
        Else
            On Error GoTo 0
        End If
    
    ' 配列の次元数を確認。
    Dim DimensionNumber As Long
        DimensionNumber = GetArrayDimension(source_array)
    
    ' 作業用配列。
    Dim TempArray As Variant
        Select Case DimensionNumber
        ' 一次元配列の場合。
            Case 1
                TempArray = source_array
        ' 二次元配列の場合、目的列を抜き出し。
            Case 2
                TempArray = WorksheetFunction.index(source_array, 0, target_column_index)
        ' 三次元以上は対応しない。
            Case Else
                GoTo er:
        End Select
                      
    ' 重複除去用の辞書（連想配列）
    Dim Dict As Object
    Set Dict = CreateObject("Scripting.Dictionary")
    Dim a As Variant
        For Each a In TempArray
            ' 配列内の各値を、辞書に格納する。
            ' 重複除去が目的のため、itemは不問。今回は「1」とした。
            ' ※空欄はリストに含めない。
            If a <> vbNullString Then
                Dict(a) = 1
            End If
        Next
        ' 辞書のkeyが、重複除去後の配列として取り出せる。
        RemovalDuplicateArray = Dict.Keys
        
        Exit Function
er:
    RemovalDuplicateArray = Array()
    On Error GoTo 0
End Function
標準モジュール

テスト用マクロがこちら。
題材は前回と同様、なんちゃって個人情報（テーブル化済み）だ。
f:id:Infoment:20200719093242p:plain

Sub ArrayTest()
    Dim arr As Variant
        With New Seaquence
            arr = .RemovalDuplicateArray(source:=ActiveSheet.ListObjects(1), _
                                         target_column_index:="都道府県")
            MsgBox Join(arr, vbNewLine)
        End With
End Sub
結果

実行して、意図した結果を得ることが出来た。
f:id:Infoment:20200719093416p:plain

これでまた、（少なくとも個人的には）業務の効率が上がった。良きかな。
なお、↓ こちらは既に更新済みです。
infoment.hatenablog.com

参考まで。

配列の重複削除 ③ 範囲やテーブルの任意の一列からも、重複の無い一次元配列を作成してみる

Excel VBA 作ってみた ユーザー定義関数

昨日は、二次元配列の任意の一列から、重複の無い一次元配列を作成してみた。
infoment.hatenablog.com

しかし、このままでは未だ足りない。もう少し機能拡張してみよう。
f:id:Infoment:20200716223638p:plain

ということで、昨日のものを少し弄ってみた。

  1. 配列だけでなく、範囲（Range）またはテーブル（ListObject）も受け取る。
  2. 範囲の場合は、「Ｌ列」のようにアルファベットでも指定できるようにする。
    ただし、範囲がＡ列から始まっていない場合は要注意。
  3. テーブルの場合は、ラベル名でも指定できるようにする。

コードが、だんだん長くなってきた。
いずれ分割も検討するとして、現状はこんな感じ。

Function RemovalDuplicateArray(ByVal source As Variant, _
                      Optional ByVal target_column_index As Variant = 1) As Variant
                      
    ' 配列確認。
    Dim source_array As Variant

    ' 配列に格納できないものがセットされる場合を想定し、一時的にエラーを無視。
        On Error Resume Next
        
    ' sourceを範囲で指定された場合。
        If TypeName(source) = "Range" Then
        ' 列番号がアルファベットで指定された場合、数値に変換する。
            If IsNumeric(target_column_index) = False Then
                target_column_index = StrConv(target_column_index, vbNarrow + vbUpperCase)
                If target_column_index Like "*[A-Z]*" Then
                    target_column_index = Cells(1, target_column_index).Column
                End If
                source_array = source.Value
            End If
        
    ' sourceがテーブルの場合。
        ElseIf TypeName(source) = "ListObject" Then
            source_array = source.DataBodyRange.Value
        ' 列がラベル名で指定されている場合、列番号に置き換える。
            If IsNumeric(target_column_index) = False Then
                target_column_index = source.ListColumns(target_column_index).Index
            End If
            
    ' sourceが上記以外であって、且つ、配列ではない場合（例えば文字列などの場合）。
        ElseIf IsArray(source) = False Then
            source_array = Array(source)
        End If
    
    ' 上記でエラーが発生していた場合の処理。
        If Err.Number <> 0 Then GoTo er:
    
    ' 配列の次元数を確認。
    Dim i As Long
        For i = 1 To 3
            Debug.Print UBound(source_array, i)
            If Err.Number <> 0 Then Exit For
        Next
        On Error GoTo 0
    
    Dim DimensionNumber As Long
        DimensionNumber = i - 1
    
    ' 作業用配列。
    Dim TempArray As Variant
        Select Case DimensionNumber
        ' 一次元配列の場合。
            Case 1
                TempArray = source_array
        ' 二次元配列の場合、目的列を抜き出し。
            Case 2
                TempArray = WorksheetFunction.Index(source_array, 0, target_column_index)
        ' 三次元以上は対応しない。
            Case Else
                GoTo er:
        End Select
                      
    ' 重複除去用の辞書（連想配列）
    Dim Dict As Object
    Set Dict = CreateObject("Scripting.Dictionary")
    Dim a As Variant
        For Each a In TempArray
            ' 配列内の各値を、辞書に格納する。
            ' 重複除去が目的のため、itemは不問。今回は「1」とした。
            Dict(a) = 1
        Next
        ' 辞書のkeyが、重複除去後の配列として取り出せる。
        RemovalDuplicateArray = Dict.keys
        
        Exit Function
er:
    RemovalDuplicateArray = Array()
    On Error GoTo 0
End Function

それではこちら、なんちゃって個人情報を元に作成したテーブルで試してみよう。
f:id:Infoment:20200716224458p:plain

都道府県の列から、重複の無い一次元配列を作成する。

Sub ArrayTest()
    Dim arr As Variant
        arr = RemovalDuplicateArray(ActiveSheet.ListObjects(1), "都道府県")
        MsgBox Join(arr, vbNewLine)
End Sub

結果がこちら。
f:id:Infoment:20200716224750p:plain

一区切りつくまで、あと少し。次回に続きます。

参考まで。