t-hom’s diary

主にVBAネタを扱っているブログ…とも言えなくなってきたこの頃。

VBA 私のコーディング風景垂れ流し動画紹介

先日Twitterでは公開したんだけど、ツイッターは鍵垢なのでこちらでも公開。

20分くらいあるので倍速再生でも良いかも。

以下に最初に動画内でテキスト入力してる内容を転記したので、1:30まで飛ばしてそこから見ていただけたら良いかと思う。

みなさんこんにちは。
この動画は、私が普段マクロを作成している様子をなるべくそのまま撮影したものです。
趣旨は、「慣れるとこれくらいのスピードで作れるよ」というのを実感してもらうことです。
ノーカットでお送りしますので、固まったように見えたら考え中です。ではつくっていきます。

なんちゃって個人情報から、個別のファイルに転記するマクロです。

※動画データを少しでも軽くするために、画面の解像度をわざと落として録画してるので、その影響で画面配置やイミディエイトウインドウの移動に苦労している。お見苦しいところを申し訳ない。
www.youtube.com

視聴にあたってのオススメポイントは、メタプログラミング。
メタプログラミングってのは、雑に言えば、コードを書くこと自体をプログラミングで行うテクニック。

以下の記事の末尾にメタプログラミングに関する記事のリンクをまとめている。
thom.hateblo.jp

特に、クラスのフィールドを準備するのは結構面倒なので、メタプログラミングを頻繁に使用する。

以上

VBA イミディエイトウインドウを使って簡単にカレンダーを作る方法

Excelでは色んな方法でカレンダーを作ることができるが、割と面倒くさい。

今回はイミディエイトウインドウを使って、以下のようなカレンダーをサクっと作る方法を紹介。
f:id:t-hom:20190301021717p:plain

まず、曜日を描きたい場所を範囲選択しておく。
f:id:t-hom:20190301022034p:plain

そしてイミディエイトウインドウで次のコードを順に実行する。

n = 1
for each r in selection:r.value = format(n,"aaa"):n=n+1:next

これで曜日の出来上がり。
f:id:t-hom:20190301022934p:plain

次に、下図のように選択する。(選択を開始する位置は、その月の1日の曜日)
f:id:t-hom:20190301023151p:plain

やり方は、Ctrlキーは選択がすべて終わるまで押しっぱなしで、各行をマウスドラッグすればOK。
このときに選択する順は必ず上からになるように注意。
f:id:t-hom:20190301023935p:plain

そして先ほどイミディエイトウインドウに書いたコードを少しだけ修正する。

n = 1
for each r in selection:r.value = n:n=n+1:next

n = 1にカーソルを合わせてEnterで実行し、次の行もEnterで実行すると、ほぼ完成。
f:id:t-hom:20190301024326p:plain

最後に、余分な日付を手動削除しておしまい。

解説

イミディエイトウインドウでは変数宣言こそできないものの、変数への代入は普通にできる。宣言も特に必要ない。
別のプロシージャが実行されるか、明示的にリセットボタン(下図)が押されるまでは有効なので、イミディエイトウインドウでコマンドを入れ続ける間は変数が保持される。
f:id:t-hom:20190301022638p:plain

また、VBAのFormat関数では、format(日付, "aaa")で曜日を取り出すことができる。VBAにおける日付型はDouble型で表され、その整数部が日付、小数部が時刻である。

数値1は1899年12月31日(日)なので、Format(1, "aaa")は日曜日を返す。

?cdate(1)
1899/12/31 
?format(1,"aaa")
日

イミディエイトウインドウでは、一度実行したコードでもカーソルを合わせると編集でき、Enterで再実行できる。実行時はカーソルが行内のどこにあっても構わない。Enterは改行ではなくコード実行になるので注意。改行したい場合はCtrl + Enter。
(マルチラインコードの実行ができるわけではないので改行という表現は微妙。改ステートメントと言ったほうが実態に近い。そんな言葉ないけど。)

For EachにSelectionを渡した場合、セルの選択順に実行される。
セル範囲の場合は1ドラッグを1範囲とみなし、選択した範囲順になる。ただし範囲内の順は左上から右下へ向かう。

分かりやすくテストしたのが以下。
f:id:t-hom:20190301025910p:plain

今これを書きながら気づいたんだけど、以下のように選択しても同じ結果になる。
f:id:t-hom:20190301030255p:plain

こっちの方が楽だ。

以上

VBA 過去直近のX曜日を求めるワンライナーコード

今回はさくっと短めの記事。

まず過去直近の日曜(当日含む)の日付を求めるコードがこちら。

?date-weekday(date,vbSunday)+1

クエスチョンマークは、イミディエイトウインドウで実行することを想定して書いている。
そして当日を含まない過去直近の日曜の日付を求めるコードはこちら。

?date - weekday(date-1,vbSunday)

どちらも曜日定数を代えると直近のその曜日が取れる。

結論は以上。

ここからは余談

当日を含まない方で、まず私が考えたのがIf文で当日の場合だけ分岐させる方法。

?iif(date = date-weekday(date,vbSunday)+1, date -7, date-weekday(date,vbSunday)+1)

もうちょっと楽にならんかなとTwitterでぼやいたところ、はけた氏より以下のアドバイスをいただいた。

weekdayの中で「date+1」とか「date-1」とか入れたら、簡単になりませんか?

なるほど、賢い。

当日を含めたくないなら、単純に前日起算してやれば良いのだ。
ということで両方のdateから1を引く。

?date-1-weekday(date-1,vbSunday)+1

 -1と+1を相殺して、こう。

?date - weekday(date-1,vbSunday)

完成。

VBA Excelがフリーズするほど大量のデータを特定列の値で分類して別シートに分ける処理

※注意 今回の記事はアイデアを記したものであり、コードの全体は掲載していません。ヒントを求めている方向けです。答えを求めてる方はごめんなさい。

Excelシートの特定列の値でレコードを分類し、個別のシートに転記する処理を作りたい場合がある。
いつもなら、レコードを1件ずつ読み取りながら転記していく。

ただ、IT運用業務ではサーバーのアクセスログなどの大量データを扱うことがあり、この方法ではどうやってもフリーズしてしまう事態に遭遇した。今回は16万件のレコード。このような大量データを扱う場合、セルに一つずつアクセスする普通のコーディングではExcelが長時間フリーズしてしまう。(大抵、会社のPCというのは普通の事務処理ができれば十分というスペックなので、家のPCよりも酷いことになる。)

ここまでデータがスケールしてしまうと、レコードを1件ずつ読み取る方式では厳しいのだ。

そこで、高速化テクの1つである、動的配列への転記を使うことにした。
thom.hateblo.jp

以下のようにシートから動的配列に転記し、それを分類ごとの動的配列に分け、各シートに転記する方法である。分類ごとの動的配列は分類名(特定列の値)をキーにして辞書型データに持たせることにする。
f:id:t-hom:20190227032305p:plain

ただ、二次元配列はそのまま扱うとやや面倒くさい。
私は普段からレコードをクラスモジュールに入れ、シートに作成したWriteLineメソッドで転記している。

たとえば、Sheet1モジュールに次のようなコードを挿入しておく。

Private Cursor As Long
Sub Init()
    Cursor = 2
End Sub
Sub WriteLine(ParamArray arr())
    For i = LBound(arr) To UBound(arr)
        Cells(Cursor, i + 1).Value = arr(i)
    Next
    Cursor = Cursor + 1
End Sub

すると、標準モジュールからは単にInitしてからWriteLineを実行するだけでデータを順次書き込むことができる。

Sub hoge()
    Sheet1.Init
    For i = Asc("A") To Asc("Z")
        Sheet1.WriteLine i, Chr(i)
    Next
End Sub

書き込み位置を指定するCursorはWriteLineメソッドの内部でインクリメントされるため、書き込みを指示するメインモジュールでは特に書き込み位置を意識しなくて良い。これは楽。

動的配列でもこれと同じ仕組みを使いたい。
そこで、WriteLineを実装したVirtualSheetというクラスを作って動的配列を格納することにした。
f:id:t-hom:20190227034114p:plain

今回、配列の動的拡張も考えていたのだが、二次元配列なので以下の制約があって諦めた。
thom.hateblo.jp

どのみちデータ量が多いので動的配列の拡張を繰り返すのは望ましくない。
そこで、VirtualSheetにInitメソッドを実装し、引数としてあらかじめレコード数を与えて配列サイズを確定させることにした。
分類ごとのレコード数はあらかじめ分類列だけを配列転記し、Dictionaryを使ってカウントしておく。
thom.hateblo.jp


更に、VirtualSheetにWriteToSheetメソッドを実行し、そこに引数で指定したワークシートにデータを書き込む処理を実装した。
f:id:t-hom:20190227035856p:plain

VirtualSheetのコードは以下のとおり。

Private arr()
Private cursor As Long
Const COLUMN_SIZE = 2
Enum Col
    列1 = 12
End Enum

Sub Init(row_size As Long)
    ReDim arr(1 To row_size, 1 To COLUMN_SIZE)
    cursor = LBound(arr, 1)
End Sub

Sub WriteLine(rc As Record)
    arr(cursor, Col.1) = rc.1
    arr(cursor, Col.2) = rc.2
    cursor = cursor + 1
End Sub

Sub WriteToSheet(ws As Worksheet)
    ws.Range(ws.Cells(1, 1), ws.Cells(UBound(arr, 1), UBound(arr, 2))).Value = arr
End Sub

今回は汎用性は犠牲にして、カラムサイズを定数で直接VirtualSheetに持たせた。WriteLineも汎用ではなく、Recordクラス型のオブジェクトを受け取って配列に格納するようにした。

Recordクラスは以下のとおり。

Public1 As Long
Public2 As String
Public Property Get Self() As Object
    Set Self = Me
End Property

最終的なデータ変換のプロセスは以下のようになった。
f:id:t-hom:20190227042753p:plain

これで20万件くらいのデータならなんとか待てるレベル。

今回私が作ったものは全体データは動的配列のまま扱ったが、実際にはSheetモジュールに動的配列を持たせ、GetNextで動的配列から1つずつ、Recordオブジェクトとして取り出す処理をしてたので、実質クラスを使ったのと同じようなことをしている。

いつもはシートからGetNextで取り出しつつ、別のシートにWriteLine。
今回はシートからGetNextで取り出しつつ、VirtualSheetにWriteLine。最後にWriteToSheet。

データ量がどれだけスケールするかによってデータ構造は使い分ける必要がある。
ただし、基本的にデータがスケール際に発生する複雑さをクラスで上手くラップしてやれば、メインロジックはだいたいいつも通りになる。

Excel 2013ではセル範囲に名前を付けるとズームアウトしたときに範囲名が表示される。

表題の件、もう何年も使ってるのに今まで知らなくて、偶然見つけてとても驚いたのでここに記しておく。
私の手元の環境でしか検証してないので他の環境は不明。

たとえばこんな風に名前が定義されていたとする。
f:id:t-hom:20190224140015p:plain

それぞれ開始セルと終了セルには私が予め文字列を書いておいた。
f:id:t-hom:20190224135804p:plain

これを25%までズームアウトすると。。。

f:id:t-hom:20190224140242p:plain


ええええええええええええええええっ!!!!!!!

ひょっとしてExcel慣れしている方からすると常識なのかもしれないけど、私は何年もExcel触ってたのに知らなかった。

で、これが何の役に立つんだって?

知らん。

VBA タイムスタンプからユニークキーを生成する。

Excelでレコードごとにユニークキーが欲しくなることがある。

ユニークキーとは、一意にアイテムを特定でき、変わることのないコードのことで、数桁の数値や文字列で表現される。
実用上は単純な連番でも全く問題ない。

ただ以下のようなシチュエーションで連番が崩れたときに、何となく気持ち悪い。

  • 項目の削除で欠番が発生したとき
  • 後からアイテムを挿入した時

人間心理としては、改めて1から番号を連番で振り直したくなるものである。
そして実際に振り直してしまう人が多いが、実はこれ、やってはいけないアンチパターンである。

もう一度いう。ユニークキーとは、一意にアイテムを特定でき、変わることのないコードである。
あるアイテムをX番だとして覚えておく。これでアイテムの名称変更があってもX番を参照すれば良い。
それさえ管理すれば安心安定のキー。絶対的に信頼できる唯一のフィールド。
それが、変わる。。だと!?もはや何も信じられない。

とはいえ、綺麗に1番からカウントされてる以上、オーダーが崩れたら気になるというのはとてもよく分かる。

どうすれば良いか。結構長いこと悩んでいたのだが、最近画期的なアイデアがひらめいた。

要するに綺麗な連番を採用するから気になるのであって、最初から意味不明なコードをユニークキーに使えば順番がバラバラだろうが何だろうが気にならなくなる!

そこで今回は、パッと見て意味が分からないユニークキーをVBAで生成してみようと思う。

今回生成するユニークキーの外観

たとえば、2019/02/19 0:59:40に生成したひとつ目のユニークキーは「XKR_2RG#0」である。
この英数字+記号の9文字で、年月日時分秒+重複に備えた連番を表すことができ、その気になれば元の日付にデコードもできる。
※今回デコード用のコードは用意してません。

前置きが長くなったけど、ここから実行結果とコードと解説

VBAコード

※コードのうち、奇数変換部分は以下の記事のものを流用させていただきました。ありがとうございます。
※流用の際、一部識別子名を変えてます。
hex309.hatenablog.com

Sub TestGetUniqueKey()
    Debug.Print Now
    Debug.Print GetUniqueKey
    Debug.Print GetUniqueKey
    Debug.Print GetUniqueKey
    
    '連番部分がリセットされることを確認するために1秒待つ
    Application.Wait Now() + TimeValue("00:00:01")
    Debug.Print Now
    Debug.Print GetUniqueKey
    Debug.Print GetUniqueKey
    Debug.Print GetUniqueKey
End Sub

Function GetUniqueKey() As String
    Static n As Long
    Static storedStamp As String
    Dim timeStamp As String
    timeStamp = _
        RadixConversion(CLng(Date), 36) & "_" & _
        RadixConversion(Hour(Time) * 60 ^ 2 + Minute(Time) * 60 + Second(Time), 36)

    If storedStamp = timeStamp Then
        n = n + 1
    Else
        n = 0
    End If
    
    storedStamp = timeStamp
    GetUniqueKey = timeStamp & "#" & n
End Function

Public Function RadixConversion(ByVal num As Long, ByVal Radix As Long) As String
    Dim Quotient As Long
    Dim Remainder As Long
    Dim Answer As String
    Quotient = num
    Do
        Remainder = Quotient Mod Radix
        Quotient = Quotient \ Radix
        Answer = GetNumChar(Remainder) & Answer
    Loop Until Quotient = 0
    RadixConversion = Answer
End Function

Private Function GetNumChar(ByVal num As Long) As String
    Dim temp As Variant
    temp = Split("0 1 2 3 4 5 6 7 8 9 A B C D E F G H I J K L M N O P Q R S T U V W X Y Z")
    GetNumChar = temp(num)
End Function

実行方法

TestGetUniqueKeyを実行するとイミディエイトウインドウにキーが3つ出力され、1秒後に続いてキーが更に3つ出力される。

例)

2019/02/19 1:24:42 
XKR_3X6#0
XKR_3X6#1
XKR_3X6#2
2019/02/19 1:24:43 
XKR_3X7#0
XKR_3X7#1
XKR_3X7#2

解説

まず日付は桁数を減らすためにCLng関数でシリアル値に変換している。

前提として、VBAでは日時データをシリアル値というDouble型の内部データで管理している。
試しにイミディエイトウインドウに「?now;vbnewline;cdbl(now)」と入力してみると、現在日時とそれをダブル型で表した数値が表示される。

2019/02/19 1:07:54 
 43515.0471527778 

このとき整数部分が日付を表す。(上の例でいうと43515が日付を表し、1899/12/31からの経過日数である。)
秒まででよければ少数部は逆に、010754と6桁で表した方が桁が少ないので、ここでは日付部分だけシリアル値を採用する。

そして日付シリアル値を1~Zまでの英数字を使って36進数で表すと2019年現在、3桁に収まる。
たとえば本日2019/2/19は、XKRである。

次に0時からの経過秒数を求め、これも36進数に変換する。
試しにイミディエイトウインドウに「?time;vbnewline;Hour(Time) * 60 ^ 2 + Minute(Time) * 60 + Second(Time)」と入力してみると、現在時刻と0時からの経過秒数が表示される。

1:17:06 
 4626 

一日は24時間なので最大値は「?24*60^2」で求まり、86400である。235959と比べて1桁少なく済む。
さて、4626を36進数に直すと、「?RadixConversion(4626,36)」で3KIと出た。

これをつなげてXKR_3KIとする。
さらに秒まで重複したときのために、末尾に#と連番を付加する。

具体的には、ユニークキーを得る関数GetUniqueKey内部で、Static変数storedStampにタイムスタンプを記録しておき、次の呼び出し時に変化が無ければStatic変数nを加算する。タイムスタンプが変化したらnをリセットすることで連番nを制御している。

おわりに

実質連番なのである程度の規則性は出てしまうけど、綺麗に1~並んでるよりは、欠番とかソート順とかが気にならなくなる。
これなら振り直したり、しないよね?

ちなみに今回のマクロは基本的におひとり様もしくは排他制御下で使うことが前提。
複数名が同時に振り出すようなシチュエーションではキーの重複もあり得るので、そのような場面には適用しないように注意。

以上

VBA オートシェイプを使って般若心経をスクロールするアニメーション

今回の記事はオートシェイプを左から右へスクロールさせながらメッセージを表示させるマクロ。
ありがたいお経を題材にしてみた。
f:id:t-hom:20190217162212g:plain

コード

クラスモジュール

クラス名は「CharBox」として、以下のコードを張り付ける。

Private sh As Shape
Private limit As Double
Private parent As Collection
Private message As String
Private nextCharBoxCreated As Boolean
Private Sub Class_Initialize()
    Set sh = Screen.Shapes.AddShape(msoShapeRectangle, 0, 0, 0, 0)
    sh.Visible = msoFalse
    sh.Line.Visible = msoFalse
    sh.Width = 50
    sh.Height = 50
    sh.Top = START_Y
    sh.Left = START_X
    sh.Fill.ForeColor.RGB = rgbWhite
    With sh.TextFrame2.TextRange.Font
        .Size = 36
        .NameComplexScript = "HGS行書体"
        .NameFarEast = "HGS行書体"
        .Name = "HGS行書体"
        .Fill.ForeColor.RGB = rgbWhite
    End With
    sh.TextFrame2.TextRange.ParagraphFormat.Alignment = msoAlignCenter
    sh.TextFrame2.VerticalAnchor = msoAnchorMiddle
    sh.Visible = msoTrue
    DoEvents
End Sub

Sub Init(c As Collection, limit_ As Double, message_ As String)
    limit = limit_
    message = message_
    Set parent = c
    c.Add Me, CStr(ObjPtr(Me))
    sh.TextFrame2.TextRange.Text = Left(message, 1)
End Sub

Function GetPercentage() As Double
    GetPercentage = (sh.Left - START_X) / (END_X - START_X)
End Function

Sub Move(amount)
    If IsMovable Then
        If GetPercentage < 0.5 Then
            n = 255 - CInt(255 * GetPercentage * 2)
        Else
            n = CInt(255 * (GetPercentage - 0.5) * 2)
        End If
        sh.Left = sh.Left + amount
        sh.TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(n, n, n)
    Else
        parent.Remove CStr(ObjPtr(Me))
    End If
    
    If Not nextCharBoxCreated Then
        If sh.Left > START_X + sh.Width Then
            nextCharBoxCreated = True
            If Len(message) > 1 Then
                With New CharBox
                    .Init parent, limit, Mid(message, 2)
                End With
            End If
        End If
    End If
End Sub

Function IsMovable() As Boolean
    IsMovable = sh.Left < limit
End Function

Private Sub Class_Terminate()
    sh.Delete
End Sub

標準モジュール

モジュール名は任意。以下のコードを張り付ける。

Public Const START_X As Double = 20
Public Const START_Y As Double = 20
Public Const END_X As Double = 500

Sub HeartSutra()
    For Each sh In Screen.Shapes
        sh.Delete
    Next
    
    Dim c As Collection
    Set c = New Collection
    With New CharBox
        .Init c, END_X, Screen.Range("A1").Value
    End With
    
    Dim cb As CharBox
    Do While c.Count <> 0
        Application.ScreenUpdating = False
        For Each cb In c
            cb.Move 2
        Next
        Application.ScreenUpdating = True
        DoEvents
    Loop
    Debug.Print "End"
End Sub

実行方法

準備

  • Excelの表示タブで枠線を消しておく
  • Sheet1のモジュール名をScreenとしておく。
  • A1セルに般若心境を入力し、白文字にして見えなくしておく。

入力するのはこちら。

仏説摩訶般若波羅蜜多心経     観自在菩薩行深般若波羅蜜多時照見五蘊皆空度一切苦厄舎利子色不異空空不異色色即是空空即是色受想行識亦復如是舎利子是諸法空相不生不滅不垢不浄不増不減是故空中無色無受想行識無眼耳鼻舌身意無色声香味触法無眼界乃至無意識界無無明亦無無明尽乃至無老死亦無老死尽無苦集滅道無智亦無得以無所得故菩提薩埵依般若波羅蜜多故心無罣礙無罣礙故無有恐怖遠離一切顛倒夢想究竟涅槃三世諸仏依般若波羅蜜多故得阿耨多羅三藐三菩提故知般若波羅蜜多是大神呪是大明呪是無上呪是無等等呪能除一切苦真実不虚故説般若波羅蜜多呪即説呪曰羯諦羯諦波羅羯諦波羅僧羯諦菩提薩婆訶般若心経

※ちなみに埵と罣はShift-JISに無くて(多分日本の文字じゃない)、行書体が無いためその2文字だけ角ばったゴシック体になってしまう。

実行

  • HeartSutraを実行するだけ

解説

今回のコードはオートシェイプ1つに対して1つのオブジェクト(CharBox型)を対応付けて管理している。

  1. CharBoxはコンストラクタでシェイプを作成する。
  2. シェイプはSTART_Xに生成され、Move命令ごとに、END_Xに向かって移動する。
  3. シェイプは移動距離が50%に達するまで、移動の度にフォントの色を徐々に濃くし、その後は100%に達するまで徐々に薄くする。
  4. CharBoxはコンストラクタとは別のInitプロシージャでコレクションを受け取り、自身の格納アドレスをキーに自身をコレクションに登録する。一方でメインマクロはコレクションのみを保持しており、CharBoxは保持していない。したがってCharBoxはコレクションから消えると参照を失って消滅する仕組み。
  5. CharBoxは、開始位置から自身の幅だけ進むと、次のCharBoxを生成する。ただし生成されたCharBoxが保持されるのはやはりコレクションのみで、CharBox同士に親子参照関係は無い。
  6. CharBoxはEND_Xに達すると自身の格納アドレスをキーに自身をコレクションから抹消する。
  7. 参照を失ったCharBoxは消滅する。消滅の直前、デストラクタによりシェイプは削除される。

当ブログは、amazon.co.jpを宣伝しリンクすることによってサイトが紹介料を獲得できる手段を提供することを目的に設定されたアフィリエイト宣伝プログラムである、 Amazonアソシエイト・プログラムの参加者です。