配列の重複除去 ② 二次元配列から任意の一列を抜き出して新たな配列作成

昨日は任意の一次元配列について、重複除去するユーザー定義関数を考えてみた。
infoment.hatenablog.com

しかし実際、自分の場合に限って言えば、一次元ではなく二次版配列の任意の一列を抜き出したうえで重複除去することの方が多い。
そこで、一次元と二次元のどちらにも対応できるよう、機能拡張してみた。

今回の作戦は、こんな感じだ。

1. 引数に、二次元配列の場合に抜き出す列番号を追加。
2. 本来配列を受け取るはずの引数に、配列以外がセットされた場合の処理追加。
3. 配列の次元確認（三次元以上は処理対象外とする）。
4. 重複除去。

これを元にして、昨日の関数を書き直してみた。

Function RemovalDuplicateArray(source_array As Variant, _
                      Optional target_column_index As Long = 1) As Variant
                      
    ' 配列確認。
    ' 引数に値以外がセットされる場合を想定し、一時的にエラーを無視。
        On Error Resume Next
        If IsArray(source_array) = False Then
            RemovalDuplicateArray = Array(source_array)
            Exit Function
        End If
    
    ' 配列の次元数を確認。
    Dim i As Long
        For i = 1 To 3
            Debug.Print UBound(source_array, i)
            If Err.Number <> 0 Then Exit For
        Next
    
    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
                RemovalDuplicateArray = Array()
        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
End Function

それでは、確認してみよう。
↓ の選択範囲のうち、２列目の「キャリア」を抜き出して重複除去する。

Sub ArrayTest()
    Dim arr As Variant
        arr = RemovalDuplicateArray(Selection.Value, 2)
        MsgBox Join(arr, vbNewLine)
End Sub

結果が ↓ こちら。

希望どおりの結果を得ることが出来た。
しかし、実用には未だ足りない。

ということで、明日に続きます。

参考まで。

配列の重複除去 ① 一次元配列

テーブルの指定列の値を一旦配列に格納し、重複除去してリストを作成するとき、いつも辞書（連想配列）を使っている。
完全にパターン化しているのに、そういえば関数化していなかった。

みんな大好き連想配列は、

• key
• item

で構成されている。普通の辞書で言えば、両者の関係は

• key リンゴ
• item バラ科リンゴ属の落葉高木樹。またはその果実のこと。

のような感じか（keyが「見出し語」で、itemが「意味」）。
そして、keyは重複が許されないことを、いつも重複除去に利用してきた。
関数にするなら、こんな感じだ。

Function RemovalDuplicateArray(source_array As Variant) As Variant
    ' 重複除去用の辞書（連想配列）
    Dim Dict As Object
    Set Dict = CreateObject("Scripting.Dictionary")
    Dim a As Variant
        For Each a In source_array
            ' 配列内の各値を、辞書に格納する。
            ' 重複除去が目的のため、itemは不問。今回は「1」とした。
            Dict(a) = 1
        Next
        ' 辞書のkeyが、重複除去後の配列として取り出せる。
        RemovalDuplicateArray = Dict.keys
End Function

早速、確認してみよう。

Sub ArrayTest()
    Dim arr As Variant
        arr = Array(1, 2, 3, 2, 1, 4, 5)
        arr = RemovalDuplicateArray(arr)
        MsgBox Join(arr, ",")
End Sub

結果は以下のとおり、二回登場した「1」「2」が除去されている。

以上が基本形。このままでも使えるが、何かと使い勝手が悪い。

ということで、次回に続きます。

参考まで。

テーブルに通し番号

テーブルの指定列に、通し番号を付すお話。

例えば、↓こんなテーブルがあるとする。

Ａ列を通し番号にしたいとき、皆さんはどうしているだろうか。
私の知る限り、方法は大別して二つ（というほど大層な話じゃない）。

1. ベタ打ち
2. 関数で表示

ベタ打ちは、とにかく番号を一つずつ入力する。
或いは、連続データでお手軽に入力してもいい。

ベタ打ちの悲しさ、途中に行の増減があった場合、全て手作業での修正を要す。

一方、関数で表示する場合、まず「一つ上に１加える」が意外と使えない。

なぜなら一行目の一つ上はラベル行であるため、一行目だけは数式ではなく数値である必要があるから。つまり、同じ列の中に数式と数値が混在するわけで。結果、行の増減に値が追従しなくなってしまう。

何より、レコード間に相関関係があるというのが、何となく落ち着かない。

ということで、今まではROW関数一択だった。

しかしこの方法も、欠点がある。テーブルの開始位置に、通し番号が追従してしまうのだ。そのたびに、数式を修正しなければならない。

不便だなと思いつつ、ずっと我慢してきた。
ところが先日、これを解決する良い方法を教わった。
方法は至ってシンプル、セルの行番号からラベルの行番号を引くだけというもの。

これは、目から鱗だった。お勧めです。

参考まで。

フォルダの階層構造を書き出してみる ③ ついでにシートに貼り付け

先日、いただいたリクエストに応えて、フォルダの階層構造を書き出してみた。
infoment.hatenablog.com

すると、追加でこんなリクエストをいただいた。
「書き出した各フォルダ名に、ハイパーリンクが設定されていたら最高です」
取り組んでみた。

まず、ハイパーリンクが設定されている時点で、シートに必ず書き出されている。しかし情報を取得した時点では未だ貼り付け不要で、配列として持っていたい場合もあるだろう。

ということで、新たな引数を一つ準備してみた。

Optional paste_to_new_sheet As Boolean = False

実際に、前回のユーザー定義関数に追加したのがこちら。

Function Tree(folder_path As String, _
     Optional contain_filename As Boolean = False, _
     Optional paste_to_new_sheet As Boolean = False) As Variant
     
    Select Case contain_filename
        Case True
            Tree = Split(CreateObject("wscript.shell").exec("cmd /c tree """ & folder_path & """ /f").stdout.readall, vbCrLf)
        Case False
            Tree = Split(CreateObject("wscript.shell").exec("cmd /c tree """ & folder_path & """").stdout.readall, vbCrLf)
    End Select
    
    Select Case paste_to_new_sheet
        Case False
            Exit Function
        Case True
            Dim Sh As Worksheet
            Set Sh = Sheets.Add
                Sh.Name = "Tree_" & Format(Now, "yyyymmdd_hhmmss")
                Range("A1").Resize(UBound(Tree) + 1) = WorksheetFunction.Transpose(Tree)
                
                With Sh.Cells.Font
                    .Underline = xlUnderlineStyleNone
                    .Name = "メイリオ"
                    .Size = 10
                End With
                
                Sh.Cells.RowHeight = 20
                Sh.Cells.EntireColumn.AutoFit
                Range("A1").Select
    End Select
End Function

結果、取得して貼り付ける側が ↓ ここまで簡素化された。

Sub test()
    Tree "C:\Temp", False, True
End Sub

次いで、ハイパーリンクを設定するためには、フォルダのフルパスが必要だ。そこで安易に、こちらを使って二回目のコマンド使用で解決を試みた。
infoment.hatenablog.com

ところが、得られた結果をツリー図の横に貼り付けてみると、期待通りの並び順になっていない。↓ の例でいえば、「野菜フォルダ」の並びに問題があった。

ハイパーリンクに設定するためには、取得したフォルダのフルパス群（配列）を昇順ソートする必要が有るようだ。そこで色々と試行錯誤した最終形が、こちら。

Function Tree(folder_path As String, _
     Optional contain_filename As Boolean = False, _
     Optional paste_to_new_sheet As Boolean = False) As Variant
     
    Select Case contain_filename
        Case True
            Tree = Split(CreateObject("wscript.shell").exec("cmd /c tree """ & folder_path & """ /f").stdout.readall, vbCrLf)
        Case False
            Tree = Split(CreateObject("wscript.shell").exec("cmd /c tree """ & folder_path & """").stdout.readall, vbCrLf)
    End Select
    
    Select Case paste_to_new_sheet
        Case False
            Exit Function
        Case True
            Dim Sh As Worksheet
            Set Sh = Sheets.Add
                Sh.Name = "Tree_" & Format(Now, "yyyymmdd_hhmmss")
                Range("A1").Resize(UBound(Tree) + 1) = WorksheetFunction.Transpose(Tree)
           
                If contain_filename = False Then
                
                    Dim arr As Variant
                        arr = Split(CreateObject("wscript.shell").exec("cmd /c Dir """ & folder_path & """ /s /b /ad").stdout.readall, vbCrLf)
        
                    Dim aryList As Object
                    Dim s As Variant
                    Set aryList = CreateObject("System.Collections.ArrayList")
                    
                        For Each s In arr
                            Call aryList.Add(s)
                        Next
                    
                    ' 昇順でソート。
                    Call aryList.Sort
                        arr = aryList.ToArray
                        Rows("1:2").Delete
                    
                        ActiveSheet.Hyperlinks.Add Anchor:=Range("A1"), Address:=Range("A1").Value
                    
                    Dim i As Long
                        For i = 2 To Sh.UsedRange.Rows.Count
                            ActiveSheet.Hyperlinks.Add Anchor:=Cells(i, 1), Address:=arr(i - 1)
                        Next
                
                End If
                
                With Sh.Cells.Font
                    .Underline = xlUnderlineStyleNone
                    .Name = "メイリオ"
                    .Size = 10
                End With
                
                Sh.Cells.RowHeight = 20
                Sh.Cells.EntireColumn.AutoFit
                Range("A1").Select
    End Select
End Function

結果、↓ のとおりハイパーリンク設定済みのツリー図が完成した。

これで一応、期待通りの動作をするものは完成した。しかし、このユーザー定義関数には未だ、重大な欠点がある。それは、動作が非常に遅いということ。階層が深くフォルダ数が多い場合、ただでさえ時間のかかるコマンドを２回も行っている。この問題を、何とか解消できないものか・・・。

次回に続く、かも知れない（諦めるかも）。

参考まで

フォルダの階層構造を書き出してみる ② ついでにファイルも

先日、いただいたリクエストに応えて、フォルダの階層構造を書き出してみた。
infoment.hatenablog.com

といっても、過去記事の焼き直しで、目新しいものは何もない。
ならば、もう少しだけ機能を拡張してみよう。

ということで今回は、ついでにファイル名も書き出してみることにした。

まず書き出しのため、先日準備したフォルダ下に、テスト用ファイルを作成。

次いで、ユーザー定義関数に「書き出し内容にファイル名を含めるか」のBoolean型変数を設けてみた。

Function Tree(folder_path As String, _
     Optional contain_filename As Boolean = False) As Variant
     
    Select Case contain_filename
        Case True
            Tree = Split(CreateObject("wscript.shell").exec("cmd /c tree """ & folder_path & """ /f").stdout.readall, vbCrLf)
        Case False
            Tree = Split(CreateObject("wscript.shell").exec("cmd /c tree """ & folder_path & """").stdout.readall, vbCrLf)
    End Select
End Function

先日とほぼ同じコードで、テストしてみよう。

Sub test()
    Dim arr As Variant
        arr = Tree("C:\Temp", True)
        Range("A1").Resize(UBound(arr) + 1) = WorksheetFunction.Transpose(arr)
End Sub

結果がこちら。

おお、出来た！と思った直後、間髪を入れず、次のリクエストが届いた。

「書き出した各フォルダ名に、ショートカットが設定されていたら最高です」

そうですか、分かりました。次回に続きます。

参考まで。

フォルダの階層構造を書き出してみる

職場で、こんなリクエストをいただいた。
「指定パス以下のフォルダについて、階層構造をExcelに書き出せませんか」

ただ羅列するのではなく、階層構造が分かるように書き出せと？
取り組んでみた。

テスト用に、Ｃドライブ下にフォルダを幾つか準備した。

書き出しのイメージとしては、こんな感じだろうか。

ところが色々調べてみるうちに、ディレクトリやファイルをツリー状に表示する「Tree」というコマンドがあることを知った。何だ、良いのがあるじゃないか。

そこで、以前紹介したこちら ↓ の三番目の方法を応用してみた。
infoment.hatenablog.com

Function Tree(folder_path As String) As Variant
    Tree = Split(CreateObject("wscript.shell").exec("cmd /c tree """ & folder_path & """").StdOut.ReadAll, vbCrLf)
End Function

それでは、テストしてみよう。

Sub test()
    Dim arr As Variant
        arr = Tree("C:\Temp")
        Range("A1").Resize(UBound(arr) + 1) = WorksheetFunction.Transpose(arr)
End Sub

結果が ↓ こちら。

見た目もそんなに悪くないし、良いかも。

参考まで。

キャリア別でシートを作成 の続き

先日、配列を編集する自作のクラスモジュール「ArrayEdit」を改修した。
infoment.hatenablog.com

しかし、どうにも気持ち悪い。自分でやっておきながら、
「元の配列を書き換える」
という行いが、何だか後ろめたくて仕方ない。

ということで何日かかけて、さらに改造してみた。

今回は、元々の配列に加え、二つの配列を準備してみた。

• source_array　元の配列
• edited_array　編集の結果得られた配列
• invers_array　編集の過程で除外された配列

三つの関係は単純で、

source_array = edited_array + invers_array

となる。なお、inverse（「逆」の意）のeが抜けているのは、何となく
文字数を揃えたかったから。

すると、先日の「キャリア別でシートを作成する」は、こんな感じになる。
　

これなら、元の配列は温存しつつ、編集結果の二つの配列を取得できる。
さらに配列を貼り付ける際も、上記三つのどれを貼るか指定できるようにした。
※クラスモジュール全文に興味のある方は、更新した ↓ こちらを参照して欲しい。
infoment.hatenablog.com

それでは、今回のテスト用コードがこちら。

Sub test()
    ' テーブル（なんちゃって個人情報）。
    Dim Tb As Excel.ListObject
    Set Tb = Sheet1.ListObjects(1)

        With New VBAProject.ArrayEdit
            ' テーブル全体を元となる配列に格納する。
            .source_array = Tb.Range
            
            ' キャリア別でシートを作成。
            Dim キャリア As String
                キャリア = .source_array(2, Tb.ListColumns("キャリア").Index)
                Do
                    .RowFilter filt:=キャリア, _
                               column_index:=Tb.ListColumns("キャリア").Index, _
                               rf_result:=rdRemain, _
                               select_array:=case_invers
                    
                    .PasteArray sheet_name:=キャリア, _
                                paste_type:=ptTable, _
                                column_autofit:=True, _
                                select_array:=case_edited
                    On Error Resume Next
                    キャリア = .invers_array(2, Tb.ListColumns("キャリア").Index)
                Loop While Err.Number = 0
        End With
End Sub

結果が ↓ こちら。

5000人のなんちゃってな方々を、１～２秒ほどで仕訳けてしまった。

個人レベルの業務改善としては、まずまずといったところかな。

参考まで。