新規シートを追加してから貼り付け

昨日の記事で、次のような操作を行った。

1. シート追加
2. 配列貼り付け

infoment.hatenablog.com
日々、それなりに登場する操作だ。
唐突に、「毎回シートを追加する」のが面倒くさくなった。
そこで、配列をシートに貼り付ける関数に、新規にシートを作成するか否かの引数を追加してみた。

' 配列をシートへ貼り付け。
Public Function PasteArray(destination As Range, _
                  Optional paste_type As PasteType = ptRange, _
                  Optional to_new_sheet As Boolean = False) As ListObject

    ' 新規シート貼り付け指定の場合、アクティブなシートの直後に
    ' 新規シートを追加する。
    If to_new_sheet Then
        Sheets.Add After:=ActiveSheet
        
        ' Rangeオブジェクトは、引数として受け取った時点でのActiveSheetに
        ' 属している（らしい）。従って、追加シートに貼り付けたい場合は、
        ' 追加シートのアドレスで再セットする必要がある。
        Set destination = ActiveSheet.Range(destination.Address)
    End If

    Dim TargetRange As Range
    Set TargetRange = destination.Resize(rMax - rMin + 1, cMax - cMin + 1)
        TargetRange = source_array
    
    If paste_type = ptTable Then
        Dim TableName As String
            TableName = "Table_" & Format(Now, "yyyymmdd_hhmmss")
    
            ActiveSheet.ListObjects.Add(xlSrcRange, _
                                        TargetRange, _
                                        , _
                                        xlYes).Name = TableName
            Set PasteArray = ActiveSheet.ListObjects(TableName)
    End If
End Function

結果、昨日のコードのこの部分、

        Sheets.Add After:=ActiveSheet
        SQC.TargetArray(arr).PasteArray Range("A1"), ptRange

は、下記のとおり一行になった。

        SQC.TargetArray(arr).PasteArray Range("A1"), ptRange, True

たった一行のことだけど、塵も積もれば山となるってことで。

クラスモジュールの全文（最新版）はこちら。
infoment.hatenablog.com

参考まで。

指定列の項目毎に、別の指定列について最大値を求める

先日、次のような課題を目にした。
例えば、昨日のなんちゃって個人情報にて。各都道府県の、最年長者を抽出した表を作成したい。

挑戦してみた。

今回の作戦は、こうだ。

1. 指定範囲を一行ずつ、都道府県をキーにして辞書に登録する。
2. 同じ都道府県の場合は年齢を比較し、登録済みの年齢よりも大きい場合、
   行ごと更新する。
3. 完成した辞書について、都道府県ごとに一行ずつ、シートに貼り付ける。

作成したコードが ↓ こちら。

Sub Sample()
    Dim 列_年齢 As Long
        列_年齢 = Rows(1).Find("年齢").Column
    Dim 列_都道府県 As Long
        列_都道府県 = Rows(1).Find("都道府県").Column
    
    Dim myRng As Range
    Set myRng = Range("A1").CurrentRegion
    Dim r As Range
    Dim Dict As Dictionary
    Set Dict = New Dictionary
    
    Dim 年齢 As Variant
    Dim 都道府県 As String
        
        For Each r In myRng.Rows
            年齢 = r.Cells(列_年齢).Value
            都道府県 = r.Cells(列_都道府県).Value
            If Dict.Exists(都道府県) = False Then
                Dict(都道府県) = r.Value
            Else
                If Dict(都道府県)(1, 列_年齢) < r.Cells(列_年齢) Then
                    Dict(都道府県) = r.Value
                End If
            End If
        Next
        
        Sheets.Add After:=ActiveSheet
        
    Dim myItem As Variant
    Dim i As Long: i = 1
        For Each myItem In Dict.Items
            Cells(i, 1).Resize(, UBound(myItem, 2)) = myItem
            i = i + 1
        Next
End Sub

結果は ↓ こちら。

意図したとおり、抽出することが出来た。ついでに、先日来シリーズで取り組んだ配列の編集クラスモジュールに、この機能を一般化して盛り込んでみた。

' 第一指定列の項目ごとに、第二指定列の指定条件のみを残す。
Public Function FilteringArrayAtDesignatedCriteria(item_column As Long, _
                                                    filter_column As Long, _
                                                    Optional filter_type As Excel.XlConsolidationFunction = xlMax)
    Dim Dict As Object
    Set Dict = CreateObject("Scripting.Dictionary")
    
    Dim myKey As Variant
    Dim FilterItem As Variant
    
        If filter_type <> xlMin And filter_type <> xlMax Then filter_type = xlMax
    
        For i = 1 To rMax
            myKey = source_array(i, item_column)
            FilterItem = source_array(i, filter_column)
            If Dict.Exists(myKey) = False Then
                Dict(myKey) = source_row_array(i)
            Else
                Select Case filter_type
                    Case xlMax
                        If Dict(myKey)(1, filter_column) < source_array(i, filter_column) Then
                            Dict(myKey) = source_row_array(i)
                        End If
                    Case xlMin
                        If Dict(myKey)(1, filter_column) > source_array(i, filter_column) Then
                            Dict(myKey) = source_row_array(i)
                        End If
                End Select
            End If
        Next
        
    ReDim TempArray(rMin To Dict.Count, cMin To cMax)
        i = 1
        For Each myKey In Dict.Keys
            For c = cMin To cMax
                TempArray(i, c) = Dict(myKey)(1, c)
            Next
            i = i + 1
        Next
        
        FilteringArrayAtDesignatedCriteria = TempArray
End Function

テストコードがこちら。例によって、クラスモジュールに委ねた分だけ、こちらはスッキリしている。

Sub sample_2()
    Dim arr() As Variant
        arr = Range("A1").CurrentRegion.Value
        
    Dim SQC As SeaquenceClass
    Set SQC = New SeaquenceClass
        arr = SQC.TargetArray(arr).FilteringArrayAtDesignatedCriteria(11, 8, xlMax)
        
        Sheets.Add
        SQC.TargetArray(arr).PasteArray Range("A1")
End Sub

結果がこちら。

こちらも、意図したとおりに動いた。良かった、良かった。

クラスモジュールの全文（最新版）はこちら。
infoment.hatenablog.com

参考まで。

名簿マスターから、印刷用にデータを抽出して並べる

昨日は名簿マスターに於いて、頭文字毎の区分けに挑戦した。
infoment.hatenablog.com

元々今回のネタは、職場の電話帳改善に端を発している。今回はクライマックス、「名簿マスターから、印刷用にデータを抽出して並べる」に挑戦する。

Ａ４用紙に、何列かに渡り改行された名簿がある。こんな感じだ。

こちらのサンプルでは、30人記載するごとに列を変えることで、用紙内に効率よく名簿を配置して１枚に収めている。

しかし、この状態で修正を重ねると、様々な表現の揺らぎが増えていく。そこで、まず名簿マスターを作成して、更新作業はマスター側で行うべきでは？となって、昨日までの内容に至った次第。

まず名簿マスターとは別のシートに、印刷用のシートを準備する。こちらのシートでは、以下のルールで名前を記載している。

1. 一列に記載する人数は、30人まで。
2. 次の列は、４行オフセットした先とする。
3. 記載するのは、イニシャル・名前・携帯の３つのみ。

こんな感じだ。

イニシャルは、名簿マスターから取得する。各列番号をそのまま利用して、名簿マスターテーブルのイニシャル列からIndex関数を用いて値を取得してみよう。

行番号を「Row()-1」としたのは、印刷用シートが２行目からデータをセットしていて、１行段違いになっているから。

この式を３０行目までコピーして、さらにＥ列にコピーすると、こうなる。

Ａ列とＥ列が、同じ値になってしまった。当たり前と言えば、当たり前。
そこで数式には、改行するたびに参照先を30行増やすような工夫が必要となる。

• １列目　⇒　０
• ５列目　⇒　１
• ９列目　⇒　２
• ｎ列目　⇒　（ｎ－１）÷４

結果、上手く改行することが出来た。

レコード数を超えるとエラーになるので、エラー処理も施しておこう。

次に、名前の列に、上記の式をコピーする。
このとき、以下の二点に注意する。

1. 参照先を「イニシャル」から「名前」に変更。
2. 列番号は、イニシャル列を参照する。

すると、このように名前が表示される。

携帯電話番号も、同様に数式をセットしてみよう。

注意点は、「名前」の場合と同じだ。

後は、等間隔に列ごとコピーするだけで、人数分の参照が可能となる。

この方式ならば、名簿マスターを更新するだけで、印刷用シートも自動的に更新される。ただしこの方式には、以下の欠点がある。

1. 改行数を変更する場合、少し手間がかかる。
2. 列数を変更する場合、式の組み直しが必要。

これ以上の汎用性を持たせるには、マクロで名簿マスターを変換して貼り付けた方が手っ取り早いかもしれません。

参考まで。

イニシャルで区分

昨日は、名簿のふりがなを「ふりがな」「フリガナ」「ﾌﾘｶﾞﾅ」の三種類で切り替えることに挑戦した。
infoment.hatenablog.com

今日は、この名簿をイニシャルで区分することに挑戦する。

本シリーズは元々、職場の「電話帳改善」に端を発している。ヒヤリングの結果、社内外からの電話を取り次ぐ際、あいうえお順に並んでいた方が探しやすいし、

• 「あ」の人
• 「い」の人

のような塊になっていれば尚良いとのこと。

そこでまずイニシャル列を追加して、LEFT関数で先頭の一文字を表示してみた。

ここからは、二つの方法を試してみよう。

１．ピボットテーブルを用いる

マスタをあれこれ弄るのは避けたく、ピボットテーブルでグループ分けしてみた。

区分けしたいだけなので、集計はしない。表形式にすると、こんな感じだ。

２．条件付き書式を用いる

マスタをいじるなら、イニシャルでソートしてしまおう。

さらに、イニシャル毎で色付けされていた方が見やすい、という意見が出た。紆余曲折有ったが、３色の色分けで落ち着いた。まず、イニシャルのコードを求める。

これで連番になっていたら、偶数・奇数で塗り分けるつもりだったのだが、
「9250 ⇒ 9252 ⇒ 9254 ・・・」
と２個とびになっていて当てが外れた。

そこでまず、２で割って小数点以下を切り上げてみた。

これで、何となく連番っぽくなった。次いで、３色に分けるため、これらの数を「０，１，２」に変換。方法として、３で割った余りを充てることにした。

最後に、コード列の数に合わせて色を変える条件付き書式を設定。0のときは色を変えないとして、適当に２色設定した。

見比べてみて、２．の条件付き書式の方が一般的かなと思う。
しかし２．は、マスター内に埋没したイニシャルを探すのが、少々大変だ。
見やすさと作り易さで言えば、必要な情報だけを集約した１．の方が良いと思う。ピボットテーブル本来の使い方からは、逸脱しているかもしれないが。

今回挑戦した内容以外にも、様々な方法があると思う。
ご使用は、時と場合とお好みで。

参考まで。

「ふりがな」と「フリガナ」と「ﾌﾘｶﾞﾅ」

昨日は情報を持たないセルに、正しいフリガナを設定することに挑戦した。

infoment.hatenablog.com

本日も、フリガナの設定についてアレコレ試してみよう。

昨日、Ｂ列（名前列）の漢字に対し、フリガナを設定した。そこで、なんちゃって個人情報本来の書式に戻すため、以下を行った。

1. Ｄ列を削除
2. Ｃ１を「フリガナ」から「ふりがな」に修正。

【修正前】

【修正後】

ここで、困ったことが起きる。ラベルは「ふりがな」なのに、実際は「フリガナ」なのだ。「ふりがな」と書かれれば平仮名で、「フリガナ」と書かれればカタカナで書くのが一般的と聞いたことがある。

そこでまず、Ｃ１のラベルを選択できるようにリスト化してみた。

1. ふりがな
2. フリガナ
3. ﾌﾘｶﾞﾅ

しかしそもそも、フィルター用の▽がある状態で、リスト選択用の▽など設定できるのか。

できた。何と、▽が二つ横並びになるのか。これは知らなかった。

それでは早速、Ｃ１の切り替えに合わせて、フリガナの種類を切り替えてみよう。

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Address <> "$C$1" Then Exit Sub
    
    ' 無限ループ防止用に一時停止。
    Application.EnableEvents = False
    Dim myRng As Range
    Set myRng = Range(Range("B2"), Range("B" & Rows.Count).End(xlUp))
    
    Select Case Range("C1")
        Case "ふりがな"
            myRng.Phonetics.CharacterType = xlHiragana
        Case "フリガナ"
            myRng.Phonetics.CharacterType = xlKatakana
        Case "ﾌﾘｶﾞﾅ"
            myRng.Phonetics.CharacterType = xlKatakanaHalf
    End Select
          
    Application.EnableEvents = True
End Sub

試した結果が、こちら。

ラベルに合わせて、ふりがなのタイプを変更することが出来た。
ところでこれって、テーブル書式でも出来るのだろうか。

試したところ、出来てしまった。

「ふりがな」と「フリガナ」と「ﾌﾘｶﾞﾅ」。
どれを使うかは、時と場合とお好みで。

参考まで。

ふりがなの設定

職場の電話帳が、Excelで作成されている。この電話帳を良くしようという、職場の改善活動にまつわるお話。

電話帳をそのまま公開できるはずもなく、今回も毎度の「なんちゃって個人情報」のお世話になる。

さて、なんちゃって個人情報には、「なんちゃって人名」と「なんちゃってふりがな」が含まれている。

この「ふりがな」は、左列の情報から抽出したものではなく、純然たる文字列だ。その証拠にPHONETIC関数をセットしても、フリガナではなく漢字が表示される。

ところで、Excelのホームタブには「ふりがなの編集」があることを、皆さまご存じだろうか。

私は知らなかった。なるほど、これは便利だ。

しかし、一個ずつセットするのは面倒だ。そこで、マクロの記録で何をしているか確かめてみた。

Sub Macro1()
    Range("B3").Select
    ActiveCell.FormulaR1C1 = "武藤 莉緒"
    ActiveCell.Characters(1, 5).PhoneticCharacters = "ムトウ　リオ"
End Sub

「ムトウ　リオ」をどのようにして得るか知りたいのに、「ムトウ　リオをセットします」という内容。これでは使い物にならない。
そこで、オブジェクトブラウザで探してみると、それっぽいものがあった。

早速試してみよう。

Sub Hide_bu()
    Range(Range("B4"), Range("B4").End(xlDown)).SetPhonetic
End Sub

まとめて一気にセットすることができた。これは便利だ。

ただ残念なことに、必ずしも正しいふりがながセットできるとは限らないようで。

その場合は、正しい値を上書きする必要がある。

Sub Hide_bu()
    Range("B10").Phonetic.Text = "ミヤタ ミツノリ"
End Sub

幸いこの表には「なんちゃってふりがな」列が既に存在するため、この値をセットしてみよう。

Sub Abe_Shi()
    Dim r As Range
        For Each r In Range("B2:B51")
            r.Phonetic.Text = r.Offset(, 2)
        Next
End Sub

結果、正しいふりがなを「名前」列にセットすることが出来た。

この手法は、どこからか名前だけコピーした名簿などで、フリガナ情報を追加したい場合に使えそうだ。

1. 名前を張り付ける。
2. SetPhoneticメソッドを用い、一括で暫定フリガナを得る。
3. 暫定フリガナの内容確認（これは手作業。仕方ない）。
4. 確認・修正した結果を返す。

違っているものだけ修正すればよいので、時間短縮が望めそうです。

参考まで。

将来の夢

職場で、Excelについて頼られることが多くなった。
頼られるってのは、まあ有難いことだ。それで、たまには皆さんの前で教鞭（？）をふるったりすることも、ある訳で。

そのような機会に面白いと思うのは、どのように初歩的な内容の講座であっても、必ず何か一つは自身も得られるものがあるってこと。

考えてみれば当たり前の話だが、もとよりExcelの全てを知っているはずもなく。謙遜でも何でもなく、私はExcelの全機能の１割も知らないと思っている。

恐らくこの先、少なくとも突然に、Excelが業務から消え去ることは無いだろう。ならば将来の夢として、地元にExcelのコミュニティを作ってみたいと思う。

一方的に教えるのではなく、教わることもあるだろう。
誰もが先生であり、誰もが生徒となる。
お互い楽しくExcelを学んで、業務に活かせればと思う。

ちなみに、コミュニティの名前だけはもう決まっている。その名も、

オシエ・オソワール

得意のダジャレを炸裂させてみた。検索したところ一件もヒットしなかったので、言ったもん勝ちで取り敢えず載せておこう。

いつか、実現することを夢見て。

参考まで。