もっと知りたい「動的配列」

f:id:bimori466:20210129144647p:plain

1 値を保持する「ReDim Preserve」

配列の宣言については過去記事を記載しております。
bimori466-1.hatenablog.com


この記事で触れていなかった動的配列の値を保持する方法について説明します。

どういうときに値の保持を使うのか?
例を出します。以下のコードをご覧ください。

Sub 配列の値を保持して再宣言()

    Dim myArr() As String
    
    ReDim myArr(1 To 1)
    
    myArr(1) = "A001"
    
    'あっ、"A002"を追加しなきゃ(;^ω^)
    
    ReDim Preserve myArr(1 To 2)
    
    myArr(2) = "A002"
    
    Debug.Print myArr(1)
    Debug.Print myArr(2)
    
End Sub

<処理解説>
1 配列変数myArr(1) を再定義。
2 myArr(1)にA001を代入。
3 配列変数myArr(2) を再定義。
  *この時、myArr(1) の値を消したくないので「ReDim Preserve myArr(1 To 2)」と記述します。「Preserve=保持」の意味です。
4 myArr(2)にA002を代入
5 イミディエイトウィンドウに値を表示。


<イミディエイトウィンドウの結果>
f:id:bimori466:20210129214147p:plain

A001、A002が表示されています。つまり、myArr(1)の値は保持されていることがわかりますね!
つまり、配列の要素数を拡張できるのです!

2 動的配列の弱点

しかし、2次元配列は行の要素数を増やすことができません
(*注:TRANSPOSE関数で行と列を入れ替えれば、追加することは可能です。ここでは割愛しますm(_ _"m))


例を出します。
以下の画像のような表から商品コードが「Aで始まる行」の2次元配列を作成します。

f:id:bimori466:20210129221039p:plain


以下のコードをご覧ください。

Sub 動的配列_二次元配列の要素数は増やせない()
    
    Dim myArr() As Variant
    
    Dim ws As Worksheet: Set ws = Worksheets("sheet1")
    Dim lastRow As Long
    Dim arrCount As Long
    
    lastRow = ws.Cells(Rows.Count, 1).End(xlUp).Row
    
    Dim i As Long
    
    For i = 2 To lastRow
        If ws.Cells(i, 1).Value Like "A*" Then
            arrCount = arrCount + 1
            ReDim Preserve myArr(1 To arrCount, 1 To 3)
            
            myArr(arrCount, 1) = ws.Cells(i, 1).Value
            myArr(arrCount, 2) = ws.Cells(i, 2).Value
            myArr(arrCount, 3) = ws.Cells(i, 3).Value
        End If
    Next

End Sub


結論、以下の通り実行時エラーとなります。
f:id:bimori466:20210129223327p:plain


エラー部分のコード

ReDim Preserve myArr(1 To arrCount, 1 To 3)

arrCount=2のときにエラーとなります。
つまり、行は要素の追加ができません。
(*注:列の要素数の追加はできます。myArr(1 To 1,1 To 4)は可能です。横に要素を増やすことはできます。)


これが2次元配列の「ReDim Preserve」の弱点です。

3 弱点を補うユーザー定義型(Type)

じゃあ配列の行を増やすことは諦めないといけないの??

諦めないで!ユーザー定義型(Type)というものがあります。

ユーザー定義型変数とは、複数の型・値を1つの変数名で管理する事が出来る型のことです。

では先ほどできなかった、商品コードが「Aで始まる行」の配列を作成しましょう!

<Typeを使った処理コード>

Type 商品
    商品コード As String
    商品名 As String
    在庫数 As Long
End Type


Sub Typeを使って配列を保持()
    
    Dim myArr() As 商品
    
    Dim ws As Worksheet: Set ws = Worksheets("sheet1")
    Dim lastRow As Long
    Dim arrCount As Long
    
    lastRow = ws.Cells(Rows.Count, 1).End(xlUp).Row
    
    Dim i As Long
    
    For i = 2 To lastRow
        If ws.Cells(i, 1).Value Like "A*" Then
            arrCount = arrCount + 1
            ReDim Preserve myArr(1 To arrCount)
            
            myArr(arrCount).商品コード = ws.Cells(i, 1).Value
            myArr(arrCount).商品名 = ws.Cells(i, 2).Value
            myArr(arrCount).在庫数 = ws.Cells(i, 3).Value
        End If
    Next
    
    Debug.Print myArr(1).商品コード; " " & myArr(1).商品名 & " " & myArr(1).在庫数
    Debug.Print myArr(2).商品コード; " " & myArr(2).商品名 & " " & myArr(2).在庫数

End Sub


*注:Typeはモジュールの宣言セクションに記載に記載します!


<処理結果>
f:id:bimori466:20210129231551p:plain


画像の蛍光線部の通り、配列の値が保持されていることがわかります。

4 クラスモジュールの自作コレクションを使う

配列とは異なりますが、ユーザー定義(Type)のように、クラスモジュールを使ってコレクションに複数の要素を持たせることができます。

*注:クラスモジュールで記述しないといけません。標準モジュールでコレクションにTypeで宣言することはできません。


クラスモジュールを使って、以下の表のSheet1のデータをSheet2に転記する処理を実行します(データ数20万件)。

<Sheet1のデータを、>
f:id:bimori466:20210207165612p:plain


<Sheet2に列D「金額」を計算したものを転記します>
f:id:bimori466:20210207165858p:plain

準備するモジュール

クラスモジュール×2、標準モジュール×1の計3つ

<クラスモジュール1 要素を定義する「商品コード」>

Option Explicit

Public 商品コード As String
Public 単価 As Long
Public 在庫数 As Long
Public 金額 As Currency


<クラスモジュール2 要素数を追加するメソッドを作る「商品コード群」>

Option Explicit

Public 商品コード群 As Collection

Private Sub class_initialize()

Set 商品コード群 = New Collection

End Sub

Public Sub Add(ByVal new商品コード As String, ByVal new単価 As Long, ByVal new在庫数 As String, ByRef new金額 As Currency)

Dim p As 商品コード: Set p = New 商品コード

With p
    .商品コード = new商品コード
    .単価 = new単価
    .在庫数 = new在庫数
    .金額 = new金額
End With
    
商品コード群.Add p, new商品コード

End Sub


<標準モジュール 金額を求める「My商品Collection2」>

Sub My商品Collection2()
Dim my商品 As 商品コード群: Set my商品 = New 商品コード群
    
    Dim ws As Worksheet: Set ws = Worksheets("Sheet4")
    Dim lastRow As Long: lastRow = ws.Cells(Rows.Count, 1).End(xlUp).Row
    
    Dim i As Long
    
    For i = 2 To lastRow
        DoEvents
        my商品.Add ws.Cells(i, 1), ws.Cells(i, 2), ws.Cells(i, 3), (ws.Cells(i, 2) * ws.Cells(i, 3))
        ws.Cells(i, 4) = my商品.商品コード群(i - 1).金額    '列Dに金額を代入
    Next
End Sub
処理の流れ

1 変数my商品を商品コード群として、インスタンス化する。
2 変数lastRowに最終行を取得する。
3 変数my商品に、クラスモジュールのメソッドADDを実行する
4 変数my商品に商品コード群を追加する。(商品コード、単価、在庫数、金額)
5 列Dに金額を求める(ws.Cells(i, 4) = my商品.商品コード群(i - 1).金額 )。


結論:この処理にかかる時間は「23分3秒」です。クソ遅いw。使えたもんじゃない。
このことをTwitterに投稿したところ、コードを見てもらって、なぜ遅いのかを調べてもらったところ以下の回答をもらいました。

プログラムが遅い一番の原因は、たぶん、下記の行です。
ws.Cells(i, 4) = my商品.商品コード群(i - 1).金額
Colletionからの読み出しで、読み出したい要素の番号を指定すると、一気に遅くなります。


つまり、my商品(1).金額と表示できれば速度が上がるはず!ということに気づきました。
しかし、現状のクラスモジュールではmy商品(1).金額と表示することができません。
しか~し、解決方法がパーフェクトVBAに載っています。

Attribute(属性)を編集する。

Attributeとはなんぞや?
ざっくり説明すると、VBE上では操作できない設定を、対象のモジュールをエクスポートして、テキストエディタなどで「Attribute」から始まる命令文を追記して、その後インポートすることで、設定できるものです。
いやいや、VBE上で設定できないなんてありかよ~(;^ω^)って感じですが、そうらしいですw


で、本題の「ws.Cells(i, 4) = my商品.商品コード群(i - 1).金額」→「ws.Cells(i, 4) = my商品().金額」するのか?
具体的に説明していきます。

1)クラスモジュールに、クラスのデフォルトメンバーに追加する処理を追記する。
<クラスモジュール 商品コード群に追記>

Public Property Get 商品index(ByVal index As Variant) As 商品コード
    Set 商品index = 商品コード群(index)
End Property


全体的にクラスモジュールをもう一度見ると以下の通り。

<クラスモジュール 商品コード群 Property Get追記後>

Option Explicit

'クラスモジュール_商品コード群

Public 商品コード群 As Collection

Private Sub class_initialize()

Set 商品コード群 = New Collection

End Sub

Public Sub Add(ByVal new商品コード As String, ByVal new単価 As Long, ByVal new在庫数 As String, ByRef new金額 As Currency)

Dim p As 商品コード: Set p = New 商品コード

With p
    .商品コード = new商品コード
    .単価 = new単価
    .在庫数 = new在庫数
    .金額 = new金額
End With
    
商品コード群.Add p, new商品コード

End Sub

Public Property Get 商品index(ByVal index As Variant) As 商品コード
    Set 商品index = 商品コード群(index)
End Property


このコード(商品コード群)をエクスポートします。
f:id:bimori466:20210207225334p:plain

5 終わりに…

いかがだったでしょうか。配列に入れると処理速度はあがりますが、動的配列でまさかの行の追加がシンプルにできません(;^ω^)
TRANSPOSE関数を使って追加する方法もありますが、シンプルじゃないのでは私の好みではありません。
Typeを使うと、シンプルに行のデータを増やすことができます。
2次元配列の動的配列の行は、動的にPreserveで値を保持して再宣言できないというお話でした。

「ReDim Preserve」は処理が遅くなるのでは?と思われるかもですが、10万件ほどのデータであれば、1秒以内に終わるようです。そんなに遅くは無いようです。


ではでは、この辺で(^^)/~~~

エクセルVBA、「配列の宣言」

f:id:bimori466:20210126155731p:plain


目次
  1 配列のメリット
  2 配列の宣言は2つある!
   1)静的配列
   2)動的配列
  3 静的配列、動的配列どちらが便利か?
  4 1次元配列と2次元配列 
   1)2次元配列の宣言(静的配列)
   2)2次元配列の宣言(動的配列)
  5 セルデータから簡単に配列を作る方法
  6 終わりに…

1 配列のメリット

同じ型の変数を宣言しなくてよい!

例を出して説明します。以下のコードをご覧ください↓↓。

Sub study_Array()

    Dim name1 As String
    Dim name2 As String

    name1 = "佐藤"
    name2 = "鈴木"
    
End Sub

変数nameの数だけ変数宣言します。1~2までしかありませんが、これが100個あったらどうでしょう??100行分の変数を宣言するのか?それは面倒だろ!という話になります。

この面倒さを解消するために「配列」が存在します。

2 配列の宣言は2つある!

1) 静的配列

先ほどの話を例に、100個の配列を宣言するにはどうすればいいのか?それは以下のコードのように宣言します。

Sub 静的配列()

    Dim myName(99) As String
    
End Sub

なぜ99なのか。理由は「0で始まるから」です。ローカルウィンドウで変数myNameを確認すると、以下の画像の通り。

f:id:bimori466:20210125102601p:plain


では、0スタートではなく、1スタートにするにはどう記述すればいいのか。答えは以下のコードの通り。

Sub 静的配列()

    Dim myName(1 to 100) As String
    
End Sub


以下の画像の通り、1スタートになります。
(「Option Base 1」をモジュールの先頭に記述しておけば、myName(100)で、要素数が100になります!詳細は割愛しますm(_ _"m))
f:id:bimori466:20210125104300p:plain


つまり、静的配列とは「最初から宣言する配列要素数が決まっている」ものになります。
では、動的配列とは何なのか?事項で説明します。

2) 動的配列

動的配列とは「あらかじめ要素数が決まっていないもの」。つまり、要素数が不確定なものです。

何を言ってるか分からないですよね(;^ω^)
説明します!

例えば、あなたが何かのセミナーを開催してるとします。セミナーの参加者名簿を作ります。参加者は、日によって異なりますよね。20人の時もあれば、今日は15人だったみたいな。そういう場合に、今回は要素数15、次は20と「変化する要素数を確定させて配列を宣言する」のです。


百聞は一見に如かず。例を出します。

f:id:bimori466:20210125112549p:plain

上の画像の通り、
1/25は10人、
1/26は5人、
1/27は3人の参加者がいます。

1/25~1/27の参加者を動的配列で宣言するにはどうすればいいか。以下のコードの通りです。

Sub 動的配列1()
    
    
    Dim ws As Worksheet: Set ws = Worksheets("sheet1")
    Dim x As Integer, y As Integer, z As Integer
    
    Dim myArr() As String   '動的配列の宣言
    
    x = ws.Cells(Rows.Count, 1).End(xlUp).Row - 1   '25日
    y = ws.Cells(Rows.Count, 2).End(xlUp).Row - 1   '26日
    z = ws.Cells(Rows.Count, 3).End(xlUp).Row - 1   '27日
    
    
    ReDim myArr(1 To x)  '10個の配列ができる
    ReDim myArr(1 To y)  '5個の配列ができる
    ReDim myArr(1 To z)  '3個の配列ができる
    
End Sub


ReDimで動的配列myArrを作成します。今回は変数x,y,zに25~27日の生徒数を代入しています。
xは10個の配列が、yは5個の配列が、zは3個の配列ができます。

動的配列に値を代入してみる。

1/25の10個の配列に、生徒コードのデータを代入してみましょう!コードは以下の通りです。

Sub 動的配列2()
    
    
    Dim ws As Worksheet: Set ws = Worksheets("sheet1")
    Dim x As Integer, y As Integer, z As Integer
    
    Dim myArr() As String   '動的配列の宣言
    
    x = ws.Cells(Rows.Count, 1).End(xlUp).Row - 1   '25日
    
    ReDim myArr(1 To x)  '10個の配列ができる
    
    '動的配列に値を代入
    Dim i As Integer
    
    For i = 1 To x
        myArr(i) = ws.Cells(i + 1, 1)
    Next
    
End Sub


このコードを動かして、ローカルウィンドウを見ると、以下の画像の通り動的配列myArrに生徒コードの値が代入できます。

f:id:bimori466:20210126082432p:plain

3 静的配列、動的配列どちらが便利か?

私は、動的配列が便利だと思います。理由は「要素数の変化に対応できるから」です。


例えば以下のような商品コードリストがあるとします。
f:id:bimori466:20210127094917p:plain

これを静的配列に値を代入するには以下のコードです。

Sub 静的配列3()

    Dim myName(1 To 10) As String
    
    myName(1) = Worksheets("Sheet2").Range("A2").Value
    myName(2) = Worksheets("Sheet2").Range("A3").Value
    myName(3) = Worksheets("Sheet2").Range("A4").Value
    myName(4) = Worksheets("Sheet2").Range("A5").Value
    myName(5) = Worksheets("Sheet2").Range("A6").Value
    myName(6) = Worksheets("Sheet2").Range("A7").Value
    myName(7) = Worksheets("Sheet2").Range("A8").Value
    myName(8) = Worksheets("Sheet2").Range("A9").Value
    myName(9) = Worksheets("Sheet2").Range("A10").Value
    myName(10) = Worksheets("Sheet2").Range("A11").Value
    
End Sub


この処理の難点は何かというと、商品リストは日々増えていくということです。

以下の画像のように、商品リストは日々増加しますよね。

f:id:bimori466:20210127100754p:plain

そうなると、静的配列の値代入のコードの書き直しが必要になります。
素数が13個に変更した場合のコードは以下の通り。

Sub 静的配列3()

    Dim myName(1 To 13) As String
    
    myName(1) = Worksheets("Sheet2").Range("A2").Value
    myName(2) = Worksheets("Sheet2").Range("A3").Value
    myName(3) = Worksheets("Sheet2").Range("A4").Value
    myName(4) = Worksheets("Sheet2").Range("A5").Value
    myName(5) = Worksheets("Sheet2").Range("A6").Value
    myName(6) = Worksheets("Sheet2").Range("A7").Value
    myName(7) = Worksheets("Sheet2").Range("A8").Value
    myName(8) = Worksheets("Sheet2").Range("A9").Value
    myName(9) = Worksheets("Sheet2").Range("A10").Value
    myName(10) = Worksheets("Sheet2").Range("A11").Value
    myName(11) = Worksheets("Sheet2").Range("A12").Value
    myName(12) = Worksheets("Sheet2").Range("A13").Value
    myName(13) = Worksheets("Sheet2").Range("A14").Value
    
End Sub


コードの変更部分は画像の蛍光線部の所です。
f:id:bimori466:20210127101412p:plain

静的配列だと、このように要素数が変更する度にコードを追加、変更しなければなりません。これは面倒(;^ω^)


では、動的配列ではどうか。結論「コードの書き換えは不要」です。

<動的配列のコード>

Sub 動的配列3()
    
    Dim ws As Worksheet: Set ws = Worksheets("sheet2")
    Dim x As Integer
    
    Dim myArr() As String   '動的配列の宣言
    
    x = ws.Cells(Rows.Count, 1).End(xlUp).Row - 1   '最終行の取得
    
    ReDim myArr(1 To x)  '変数xの数だけ配列ができる
    
    
    '動的配列に値を代入
    Dim i As Integer
    
    For i = 1 To x
        myArr(i) = ws.Cells(i + 1, 1)
    Next
    
End Sub


<要素数が10の場合>
f:id:bimori466:20210127102700p:plain


<要素数が13の場合>
f:id:bimori466:20210127102850p:plain


明らかに動的配列が楽です。

しかし、静的配列も曜日のような定数的な値をいれる場合は効果的だと思います。


(例)曜日を静的配列に代入。

sub 静的配列_曜日 
    Dim Day_of_the_week(6) As String

    Day_of_the_week(0) = "日"
    Day_of_the_week(1) = "月"
    Day_of_the_week(2) = "火"
    Day_of_the_week(3) = "水"
    Day_of_the_week(4) = "木"
    Day_of_the_week(5) = "金"
    Day_of_the_week(6) = "土"

End Sub

4 1次元配列と2次元配列

いままで説明してきたのが1次元配列についてです。ここからは2次元配列について説明していきます。

1)2次元配列の宣言(静的配列)

以下のようなエクセルの表があるとします。
f:id:bimori466:20210128034049p:plain


この表を静的配列に代入してみましょう!

<2次元配列を静的配列に代入するコード>

Sub 静的配列_2次元配列1()
    
    Dim myProductArr(1 To 11, 1 To 3) As String
    
    Dim ws As Worksheet: Set ws = Worksheets("sheet3")
    Dim myRow As Long
    Dim myColumn As Long
    
    '配列に代入
    For myRow = 1 To 11
        For myColumn = 1 To 3
            myProductArr(myRow, myColumn) = ws.Cells(myRow, myColumn).Value
        Next
    Next
    
    'イミディエイトウィンドウに出力する。
    Dim i As Integer
    
    For i = 1 To 11
        Debug.Print myProductArr(i, 1) & " " & myProductArr(i, 2) & " " & myProductArr(i, 3)
    Next
    
End Sub


処理結果は以下の画像の通り。
f:id:bimori466:20210128043035p:plain

ローカルウィンドウを確認すると以下の画像の通り。2次元配列にデータが変数myProductArrにデータが代入されていることがわかります。
f:id:bimori466:20210128043718p:plain

2)2次元配列の宣言(動的配列)

<2次元配列を動的配列に代入するコード>

Sub 動的配列_2次元配列1()
    
    Dim myProductArr() As String
    
    Dim ws As Worksheet: Set ws = Worksheets("sheet3")
    Dim myRow As Long
    Dim myColumn As Long
    
    Dim lastRow As Long
    Dim lastColumn As Long
    
    lastRow = ws.Cells(Rows.Count, 1).End(xlUp).Row
    lastColumn = ws.Cells(1, Columns.Count).End(xlToLeft).Column
    
    ReDim myProductArr(1 To lastRow, 1 To lastColumn)
    
    '配列に代入
    For myRow = 1 To lastRow
        For myColumn = 1 To lastColumn
            myProductArr(myRow, myColumn) = ws.Cells(myRow, myColumn).Value
        Next
    Next
    
    'イミディエイトウィンドウに出力する。
    Dim i As Integer
    
    For i = 1 To 11
        Debug.Print myProductArr(i, 1) & " " & myProductArr(i, 2) & " " & myProductArr(i, 3)
    Next
    
End Sub


処理結果は以下の画像の通り(静的配列と同じ結果です)。
f:id:bimori466:20210128050214p:plain


ローカルウィンドウを確認。(静的配列と同じ結果です)。
f:id:bimori466:20210128050851p:plain


このように、静的配列は「Dim myProductArr(1 To 11, 1 To 3) As String」で2次元配列を宣言できます。
動的配列は、「Dim myProductArr() As String」で宣言し、「ReDim myProductArr(1 To lastRow, 1 To lastColumn)」で2次元配列を再宣言します。

5 セルデータから簡単に配列を作る方法

結論、配列変数をVariantで宣言してセルの範囲を代入する。

どういうことか分からないですよね(;^ω^)
説明します。

以下の画像の表をデータを配列に取り込みます。

f:id:bimori466:20210128084957p:plain


以下のコードをご覧ください。

Sub Variantに配列を代入()
    
    Dim ws As Worksheet: Set ws = Worksheets("sheet3")
    
    Dim myAyy As Variant
    
    myAyy = ws.Range("A1:C11")
    
End Sub


ローカルウィンドウを確認すると、変数myAyyに配列ができていることが確認できます。
f:id:bimori466:20210128084836p:plain

配列データをセルに一括代入する。

セルから配列を作れる作れるように、
配列データをセルに一括で代入することができます。


例を出します。以下の画像のような表を用意します。

f:id:bimori466:20210128150801p:plain

この表の「金額」を配列変数に取得した後計算し、配列変数ををセルに一括代入します。


<「金額」を求め、セルに配列を代入する処理コード>

Sub Variantに配列を代入2()
        
    Dim ws As Worksheet: Set ws = Worksheets("sheet4")
    Dim lastRow As Long
    Dim myAyy As Variant
    
    lastRow = ws.Cells(Rows.Count, 1).End(xlUp).Row
    
    myAyy = ws.Range("A1:D" & lastRow)
    
    Dim i As Long
    
    '列Dの金額を配列に代入する処理
    For i = 2 To lastRow
        myAyy(i, 4) = myAyy(i, 2) * myAyy(i, 3)
    Next
    
    '配列を列に代入する。
    ws.Range("A1:D" & lastRow) = myAyy
    
End Sub


コードの実行後の結果は以下の画像の通り。「金額」の値が代入されています!

f:id:bimori466:20210128152035p:plain


20万件の計算処理時間は「3秒」です。
ちなみに、配列に入れずに、セル参照をして処理をすると「12秒」かかります。
なんと「1/4」の時間の短縮になります。


配列の便利さを理解頂けましたでしょうか??

6 終わりに…

以上が配列の宣言をざっくりまとめたものです。ReDimは値を保持する「Preserve」を使うパターンもあるのですが、またの機会に記載します。


記事記載しました↓↓
bimori466-1.hatenablog.com


ではでは、この辺で(^^)/~~~

ステータスバーを表示する方法

ステータスバーを表示する

以下の画像の通り、処理に時間のかかるマクロを動かす場合ステータスバーに処理状況を表示することがあると思います。

f:id:bimori466:20210123084423p:plain


ステータスバーを処理方法をまとめたことがなかったので、調べてまとめました。

ステータスバーを表示するコード

Sub StatusBar変更()
    
    With Application
        .DisplayStatusBar = True
        .StatusBar = "時間のかかる処理をしています。"
        .DisplayStatusBar = False
    End With
    
End Sub


「Application.DisplayStatusBar = True」にすることで、ステータスバーを表示します。
「Application.StatusBar」に表示したい文字を入力します。
「Application.DisplayStatusBar = False」でステータスバーの表示無くします。

処理時間のかかるマクロを動かす場合には活用するといいかもです!

Twitterでのツッコミ

ユーザー側の設定を勝手に変えてしまうと、場合によっては大問題につながるケースもある。

そこで、教えていただいたコードをまるパクリしましたw。

Sub StatusBar変更2()
    
    Dim DisplayStatusBar As Boolean
    
    With Application
        DisplayStatusBar = .DisplayStatusBar
        
        'ステータスバーが非表示なら表示
        If DisplayStatusBar = False Then .DisplayStatusBar = True
        
        'ステータスバーの更新
        .StatusBar = "時間のかかる処理をしています。"
        
        'ステータスバーが非表示だったら元に戻す
        If DisplayStatusBar = False Then .DisplayStatusBar = False
    End With

End Sub


これなら、変数DisplayStatusBar がTure、Falseでステータスバーの表示を切り替えられるのでユーザーの設定を変更せずに済みます!
ステータスバーの状態をBoolean型で取得するとは思いつきもしませんでした。勉強になりましたm(_ _"m)


ではでは、この辺で(^^)/~~~

VBA100本ノック 45本目:テーブルに列追加

この記事から得るもの

ListObjectの追加した行に、数式を一括代入する方法が分かる。
ListObjectの追加した行に、値のみを代入する方法が分かる。


1 今回のお題

シートにB2から始まる5列(列1,列2,列3,列4,列5)のテーブルあります。
・列3の後ろに列挿入して列1から列3の合計列を作成、見出しは"合計列1"
・テーブルの右端に列4から列5の合計列を作成、見出しは"合計列2
出来上がりは画像を参照してください。
※シートは任意

f:id:bimori466:20210122032443p:plain

excel-ubara.com

2 今回のお題の意図

DataBodyRangeを使って数式を一括代入すると楽ということを伝えたい。

3 回答

ListObjectについてまだ知識が浅いので、サイト管理者のコードをひとまずコピペしました。

サイト管理者のコード

Sub VBA100_45_01()
    Dim ws As Worksheet: Set ws = ActiveSheet
    
    With ws.Range("B2").ListObject
        With .ListColumns.Add(.ListColumns("列3").Index + 1)
            .Name = "合計列1"
            .DataBodyRange.Value = "=SUM([@[列1]:[列3]])"
            .DataBodyRange.Select
        End With
    
        With .ListColumns.Add
            .Name = "合計列2"
            .DataBodyRange.Formula = "=SUM([@[列4]:[列5]])"
        End With
    End With
End Sub

DataBodyRangeって何??

マイクロソフトのサイト解説によると、「テーブルの見出しの行を除く、値の範囲を表す Range オブジェクトを返します。 読み取り専用です。」との記述でした。

例文

ActiveSheet.ListObjects.Item(1).DataBodyRange.Select


この処理を実行すると、選択されるセルは以下の画像の通りです。

f:id:bimori466:20210122033459p:plain

マイクロソフトの解説の通り、テーブルの見出しの行を除く、値の範囲を表す Range オブジェクトが選択されました。

しかし、これではすべてのデータ部が選択されてしまいます。なので、追加した列だけを選択するにはどうしたらいいか。
以下のコード部をみてください。

  With ws.Range("B2").ListObject
        With .ListColumns.Add(.ListColumns("列3").Index + 1)
            .Name = "合計列1"
            .DataBodyRange.Value = "=SUM([@[列1]:[列3]])"
            .DataBodyRange.Select
        End With

「.DataBodyRange.Select」を実行すると、追加した行のデータ部のみを選択します。
また、「.DataBodyRange.Value = "=SUM([@[列1]:[列3]])"」で一括で追加した行にSumの数式を代入でき、簡単に数値の合計を入力できます。以下の画像をご覧ください。

f:id:bimori466:20210122034359p:plain

セルに数式を入れたくない!という私のポリシー

このデータ量なら問題ないのですが、リストが大きくなると数式を入れるとデータ量が重くなり動作が遅くなります。個人的には、セルに数式を代入するのは好きではありません。
しかし、「.DataBodyRange.Value」は数式を一括代入はできるのですが、値のみを代入することはできないようです。そのため、私の考えたコードは以下になります。

私の作成したコード

Sub ノック45本目_1()

    '変数定義-------------------------------------------------------
    Dim ws As Worksheet: Set ws = Worksheets("Sheet1")
    Dim lastRow As Long, k_listRow As Long
    '________________________________________________________________
    
    
    lastRow = ws.Range("A1").ListObject.Range.Rows.Count
    
    '追加行のデータ作成、数値合計
    With ws.Range("A1").ListObject
        .ListColumns.Add Position:=4
            
        .ListColumns(4).Range(1) = "合計列1"
        
        For k_listRow = 2 To lastRow
            .ListColumns(4).Range(k_listRow) = WorksheetFunction.Sum(Range(Cells(k_listRow, 1), Cells(k_listRow, 3)))
        Next
        
        
        .ListColumns.Add
        
        .ListColumns(7).Range(1) = "合計列2"
        
        For k_listRow = 2 To lastRow
            .ListColumns(7).Range(k_listRow) = WorksheetFunction.Sum(Cells(k_listRow, 5), Cells(k_listRow, 6))
        Next
    End With
    
End Sub


リストを追加する部分は同じです。異なる点は、「.DataBodyRange.Value = "=SUM([@[列1]:[列3]])"」で数式を一括代入するのではなく、For Nextでループし、「WorksheetFunction.Sum」で数値を合計し値のみを追加した行に代入しています。これなら、大量のリストでもデータ量は軽くなるばずです。

4 感想

「.DataBodyRange.Value」は数式を一括代入はできるという便利なものだと初めて知りました。
一方で、数式を代入することに抵抗がある私は、値のみを代入する方がいいなと感じます。
しかし、これはユーザーの要望次第になるので、どちらでも臨機応変に対応できるようにしたいところですね。


ではでは、この辺で(^^)/~~~

PATHの末尾に「¥」を付ける自作関数

「¥」を付ける自作関数

Twitterで、マクロにエラーが出た原因が最後に「¥」を付けていないのが原因でエラーだったというツイートを見ました。
その返信で、自作関数で作っている!という方がいたので、自分でも作ってみました。

自作関数コード

Sub パス設定()

    Dim myPath As String
    
    myPath = SetPath(ThisWorkbook.Path)
    
    MsgBox myPath

End Sub


Function SetPath(ByRef beforPath As String) As String
    
    If Len(beforPath) <> 0 Then
        If Right(beforPath, 1) = "¥" Or Right(beforPath, 1) = "/" Then
            SetPath = beforPath
        Else
            SetPath = beforPath & "¥"
        End If
    End If

End Function

★注 「¥」はブログ上全角となっております。コピペした後は、半角「¥」へ訂正が必要です!!

変数myPath にThisWorkbookのPathを取得する。
Right関数を使って、末尾「¥」or「/」でなければ「¥」をつける。

この自作関数をPath設定時に記述に追加すれば、エラーに悩む時間が減る!!
これをアドインで展開すれば楽になるのだろうか??


ではでは、この辺で(^^)/~~~

保育料日付入力Form。一時保育時に、封筒に手書きで書いていることを楽にする。

保育料日付入力Formの作成の経緯

f:id:bimori466:20210110224404p:plain

妻が仕事をするために1ヵ月の間に12日、子どもを一時保育に預けています。その際に、毎回上記の添付写真の封筒を手書きで作っていました。
「それ面倒じゃない?」と聞くと、「いや、1月に12回だけだからw」と返答され、ありえない!面倒くさい!意味わからん!と、私のよくわからない情熱が燃え、この作業を自動化するVBAを作成することにしました。


1 閲覧対象者

お子さんを一時保育などに預けており、毎回手書きで「保護者名」、「園児名」、「緊急連絡先」、「登園日」、「金額」を書いている方。

2 得られる効果

手書きからの解放!!


処理イメージ↓↓


「登園日」以外は固定されているので、今回は日付を入力するという点にフォーカスを当てた仕様となっております。
仮に「登園日」以外に変更がある場合は、都度変更すればよいかと思います。

3 設計

1 「保護者名」、「園児名」、「緊急連絡先」、「金額」はマニュアル入力。

f:id:bimori466:20210110231739p:plain

2 マクロ「登園日入力」を実行

f:id:bimori466:20210110232329p:plain

3 ユーザーフォームが表示される。

f:id:bimori466:20210110232710p:plain

4 登園する日付のCheckboxをチェックし、登録ボタンをクリックする。

f:id:bimori466:20210111065553p:plain

5 日付が入力される。

f:id:bimori466:20210111065755p:plain

4 コードの解説

コードの中身

標準モジュールが1つと、Formモジュール(Calender)1つ、計2つがあります。

<標準モジュール>

(Formモジュール(Calenderを呼出す(Show)するだけ)

f:id:bimori466:20210112050329p:plain

<フォームモジュール>

f:id:bimori466:20210112050432p:plain


標準モジュールは、今日の日付(Date)を取得してFormモジュール(Calender)を呼び出すだけです。なので、標準モジュールの説明は省きます。
メイン処理は、Formモジュール(Calender)になります。

Formモジュール(Calender)の処理

UserForm_Initialize処理(ここがメイン処理です!)

<UserForm_Initializeのコード>

Private Sub UserForm_Initialize()

    Dim Day_of_the_week(6) As String
    Day_of_the_week(0) = "日": Day_of_the_week(1) = "月": Day_of_the_week(2) = "火"
    Day_of_the_week(3) = "水": Day_of_the_week(4) = "木": Day_of_the_week(5) = "金"
    Day_of_the_week(6) = "土"
    
    
    
    '曜日のラベルを作成----------------------------------------------
    Dim newLabel As MSForms.Label
    Dim k_Day_of_the_week As Byte
    
    For k_Day_of_the_week = 0 To 6
        '名前をつけてラベルを追加
        Set newLabel = Me.Controls.Add("Forms.Label.1", "lab_" & Day_of_the_week(k_Day_of_the_week))
            With newLabel
                .Caption = Day_of_the_week(k_Day_of_the_week)   'キャプション
                .Font.Size = 14         '文字サイズ
                .Width = 35             '横幅
                .Height = 18            '縦幅
                .Left = 24 + (40 * k_Day_of_the_week)        '左からの距離
                .Top = 60               '上からの距離
                '.BorderStyle = fmBorderStyleSingle      'ラベルに線で囲う。
                
                If Day_of_the_week(k_Day_of_the_week) = "日" Then
                    .ForeColor = &HFF&      '文字色を赤
                
                ElseIf Day_of_the_week(k_Day_of_the_week) = "土" Then
                    .ForeColor = &HFF0000   '文字色を青
                Else
                    .ForeColor = &H0&       '文字色を黒
                End If
                    
                .TextAlign = fmTextAlignCenter
            End With
        Set newLabel = Nothing
    Next
    '________________________________________________________________


    'コンボボックス登録処理------------------------------------------
    Dim i As Integer
    
    For i = -3 To 3 '前後3年分の年を登録
        Me.cmb_year.AddItem CStr((Year(clndr_date)) + i)
      Next i
      For i = 1 To 12 '月を登録
        Me.cmb_month.AddItem CStr(i)
      Next i
        
      Me.cmb_year = Year(clndr_date) '年を指定
      Me.cmb_month = Month(clndr_date) '月を指定
    '________________________________________________________________
    
    
    '日付のcheboxを作成--------------------------------------------------
    Dim DayLabel As MSForms.CheckBox
    Dim Left_IX  As Integer, Top_IX As Integer, n As Byte
    Dim k_DayLabel As Byte
    
    Left_IX = 0: Top_IX = 0: n = 0
    
    For k_DayLabel = 1 To 37
        
        
        Set DayLabel = Me.Controls.Add("Forms.CheckBox.1", "lab_Day_" & k_DayLabel)       '名前をつけてラベルを追加
            With DayLabel
                .Caption = k_DayLabel   '後で削除
                .TextAlign = fmTextAlignCenter
                .Font.Size = 14         '文字サイズ
                .Width = 35             '横幅
                .Height = 18            '縦幅
                .Left = 25 + (40 * Left_IX)     '左からの距離
                .Top = 100 + (18 * Top_IX)        '上からの距離
                '.BorderStyle = fmBorderStyleSingle      'ラベルに線で囲う。
                
                If k_DayLabel Mod 7 = 0 Then
                    .ForeColor = &HFF0000   '文字色を青
                ElseIf k_DayLabel Mod 7 = 1 Then
                    .ForeColor = &HFF&      '文字色を赤
                Else
                    .ForeColor = &H0&       '文字色を黒
                End If
                    
            End With
            
            
            'Debug.Print Me("lab_Day_" & k_DayLabel).Caption
            
            
        Set DayLabel = Nothing
        
        Left_IX = Left_IX + 1
        n = n + 1
        
        '7個作ったら、下に作る判定
        If n = 7 Then
            n = 0
            Top_IX = Top_IX + 1
            Left_IX = 0
        End If
        
    Next
    '____________________________________________________________________
    
    Call spn_日付_Spinup    'この処理をしないと面倒なことに…

End Sub

Formモジュール(Calender)の処理手順

1 配列変数Day_of_the_weekに日曜~土曜日の文字列を格納します。

 Dim Day_of_the_week(6) As String
    Day_of_the_week(0) = "日": Day_of_the_week(1) = "月": Day_of_the_week(2) = "火"
    Day_of_the_week(3) = "水": Day_of_the_week(4) = "木": Day_of_the_week(5) = "金"
    Day_of_the_week(6) = "土"

2 曜日のラベルを作成

f:id:bimori466:20210112230110p:plain

上の画像の通り、フォームモジュールには曜日のラベルはありません。ラベルを作るコードを記述しています。


<ラベルを作成するコード>

'曜日のラベルを作成----------------------------------------------
    Dim newLabel As MSForms.Label
    Dim k_Day_of_the_week As Byte
    
    For k_Day_of_the_week = 0 To 6
        '名前をつけてラベルを追加
        Set newLabel = Me.Controls.Add("Forms.Label.1", "lab_" & Day_of_the_week(k_Day_of_the_week))
            With newLabel
                .Caption = Day_of_the_week(k_Day_of_the_week)   'キャプション
                .Font.Size = 14         '文字サイズ
                .Width = 35             '横幅
                .Height = 18            '縦幅
                .Left = 24 + (40 * k_Day_of_the_week)        '左からの距離
                .Top = 60               '上からの距離
                '.BorderStyle = fmBorderStyleSingle      'ラベルに線で囲う。
                
                If Day_of_the_week(k_Day_of_the_week) = "日" Then
                    .ForeColor = &HFF&      '文字色を赤
                
                ElseIf Day_of_the_week(k_Day_of_the_week) = "土" Then
                    .ForeColor = &HFF0000   '文字色を青
                Else
                    .ForeColor = &H0&       '文字色を黒
                End If
                    
                .TextAlign = fmTextAlignCenter
            End With
        Set newLabel = Nothing
    Next
    '________________________________________________________________


「Set newLabel = Me.Controls.Add("Forms.Label.1", ラベル名)」この処理でラベルを作ります。作った後は、文字、配置などを微調整します。

f:id:bimori466:20210112230851p:plain

蛍光線の部分のラベルが作成される。

3 コンボボックス登録処理

年、月のコンボボックスに値を代入します。年は±3年、月は1~12の値を代入します。これで、±3年の日付の入力ができます。

f:id:bimori466:20210112231226p:plain


<コンボボックス登録処理のコード>

 'コンボボックス登録処理------------------------------------------
    Dim i As Integer
    
    For i = -3 To 3 '前後3年分の年を登録
        Me.cmb_year.AddItem CStr((Year(clndr_date)) + i)
    Next i
    For i = 1 To 12 '月を登録
        Me.cmb_month.AddItem CStr(i)
    Next i
          
    Me.cmb_year = Year(clndr_date) '年を指定
    Me.cmb_month = Month(clndr_date) '月を指定
    '________________________________________________________________

4 日付のcheboxを作成処理

ラベル同様に、カレンダーの日付もフォームモジュール内には存在しないので、コードから作成します。


<日付のcheboxを作成するコード>

 '日付のcheboxを作成処理------------------------------------------
    Dim DayLabel As MSForms.CheckBox
    Dim Left_IX  As Integer, Top_IX As Integer, n As Byte
    Dim k_DayLabel As Byte
    
    Left_IX = 0: Top_IX = 0: n = 0
    
    For k_DayLabel = 1 To 37
        
        
        Set DayLabel = Me.Controls.Add("Forms.CheckBox.1", "lab_Day_" & k_DayLabel)       '名前をつけてラベルを追加
            With DayLabel
                .Caption = k_DayLabel   '後で削除
                .TextAlign = fmTextAlignCenter
                .Font.Size = 14         '文字サイズ
                .Width = 35             '横幅
                .Height = 18            '縦幅
                .Left = 25 + (40 * Left_IX)     '左からの距離
                .Top = 100 + (18 * Top_IX)        '上からの距離
                '.BorderStyle = fmBorderStyleSingle      'ラベルに線で囲う。
                
                If k_DayLabel Mod 7 = 0 Then
                    .ForeColor = &HFF0000   '文字色を青
                ElseIf k_DayLabel Mod 7 = 1 Then
                    .ForeColor = &HFF&      '文字色を赤
                Else
                    .ForeColor = &H0&       '文字色を黒
                End If
                    
            End With
            
        Set DayLabel = Nothing
        
        Left_IX = Left_IX + 1
        n = n + 1
        
        '7個作ったら、下に作る判定
        If n = 7 Then
            n = 0
            Top_IX = Top_IX + 1
            Left_IX = 0
        End If
        
    Next
    '____________________________________________________________________


「Set DayLabel = Me.Controls.Add("Forms.CheckBox.1", チェックボックス名)」これで、日付のチェックボックスを作成します。

f:id:bimori466:20210112232628p:plain

5 この処理をしないと面倒なことに…

最後にちょこんと書いてあるこのコード。

Call spn_日付_Spinup    'この処理をしないと面倒なことに…

何をしているかと言うと、スピンボタンをスピンアップしています。
なぜこんなことをするのか?変数clndr_dateにDate関数で日付を取っているから、翌月を表示するため…ではありません。解決できないエラーがあったからです(;^ω^)。

仮にこの処理をしなかった場合、フォームの表示は下の画像の通りになります。

f:id:bimori466:20210112233956p:plain

UserForm_Initializeの処理が流れただけの結果となります。これではカレンダーとは言えません。
スピンボタンにスピンUP、Downしたときに、カレンダーを作成する処理を走らせています。
その処理を実行すると、カレンダーが作成されます。つまり、自分でもあまり分かっていません(;^ω^)

動いてるからいいかなぁ(;^ω^)という状態です。

故に、スピンUP、Down時のイベント処理「clndr_set」のなかで、 On Error Resume Nextでエラーを無視しています。
この理由がわかる方は教えていただけると幸いです。しかし、設計に対して必要な要件は満たしています。

朗報 エラーの原因わかりました。

結論

UserForm_Initializeの最後「Call spn_日付_Spinup 」→「Call clndr_set」。
そもそも、UserForm_Initializeでカレンダー作成処理をやっていないことが原因でした(;^ω^)
なので、カレンダー作成処理を実行すればOKです。noteも更新しておりますm(_ _"m)

ご指摘くださったお二方、本当にありがとうございましたm(_ _"m)


<clndr_setのコード>

Private Sub clndr_set() 'カレンダーの作成と表示
    
    Dim yy As String, mm As Integer, i As Integer, n As Integer, endDay As Integer
    
    If Me.cmb_year = "" Or Me.cmb_month = "" Then Exit Sub '年か月どちらか入ってなければ中止
    yy = Me.cmb_year '年
    mm = Me.cmb_month '月
    
    On Error Resume Next
    
    For i = 1 To 37 'ラベルの初期化
      Me("lab_Day_" & i).Caption = ""
      Me("lab_Day_" & i).BackColor = Me.BackColor
    Next
    
    n = Weekday(yy & "/" & mm & "/" & 1) - 1 'その月の1日の曜日番号に、マイナス1したもの
    endDay = Day(DateAdd("d", -1, DateAdd("m", 1, yy & "/" & mm & "/" & "1"))) '月末日の算出
    For i = 1 To endDay
      Me("lab_Day_" & i + n).Caption = i '日を入れる
      If CDate(yy & "/" & mm & "/" & i) = clndr_date Then Me("lab_Day_" & i + n).BackColor = RGB(200, 200, 200) 'TextBoxの日と同じなら色をつける
    Next i
    
    On Error GoTo 0
    
End Sub


この処理で、カレンダーを作成しています。

5 使ってみたい方はnoteで無料DL

実際に使ってみたい方は、noteより無料ダウンロード可能です。
note.com


ではでは、この辺で(^^)/~~~

VBA100本ノック 44本目:全テーブル一覧作成

この記事から得るもの

1つのBook内にあるすべてのテーブル情報を取得する。


1 今回のお題

ブック内の全シート全テーブルについて、以下の情報をシートに出力してください。
・A列にテーブル名(テーブル1)
・B列にシート名(Sheet1)
・C列にセル範囲($B$2:$F$12)
・D列にリスト行数(10)
・E列にリスト列数(5)
※()内は画像の出力例
※対象ブック及び出力シートは任意

f:id:bimori466:20210108222323p:plain

excel-ubara.com

2 今回のお題の意図

お題を読んだだけでは意図が分からなかったので補足動画GIFをつけました↓↓


動画の例で言うと、Sheet1~Sheet3の中にテーブルが計4つあります。そのテーブルの情報(テーブル名、シート名、セル範囲、行数、列数)を取得することが今回のお題の意図になっています。

3 回答

ListObjectを初めて知ったので、順を追って解説していきます。

まずは、Sheetにテーブルが存在するかどうかを判断しなければなりません。判断するためのコードが以下のコード↓↓

Sub テーブルが存在するか判定する_アクティブシート()

    Dim listObjectCount As Integer
    Dim DB1 As ListObject
    
    listObjectCount = ActiveSheet.ListObjects.Count
    
    If ActiveSheet.ListObjects.Count = 0 Then
      MsgBox "テーブルは存在しません。"
    Else
      MsgBox "テーブルが存在します。"
    End If
        
    
    For Each DB1 In ActiveSheet.ListObjects
        Debug.Print DB1.Name
    Next

End Sub

処理結果

f:id:bimori466:20210109065554p:plain


これはSheet3をActiveにした時の処理結果です。テーブルが2つあるので、イミディエイトウィンドウに2つのテーブル名を返します。
重要な点は、「 ActiveSheet.ListObjects.Count」で、SheetにあるListObjectsの数を数えられるという点です。
つまり、このお題をクリアするためにはすべてのSheetをループして、ListObjectsの数だけループすればよいということです。

私の最終回答

Option Explicit

Sub ノック44本目_2()

    '変数宣言--------------------------------------------------------
    Dim sh As Worksheet
    Dim listObjectCount As Integer
    Dim i As Integer
    Dim tableName As String
    Dim tableSheetName As String
    Dim tableRange As String
    Dim tableRowCount As Long
    Dim tableColumnCount As Long
    Dim ws As Worksheet: Set ws = Worksheets("テーブル一覧")
    Dim write_IX As Long: write_IX = ws.Cells(Rows.Count, 1).End(xlUp).Row
    '________________________________________________________________
    
    For Each sh In Sheets
        listObjectCount = sh.ListObjects.Count
            
        For i = 1 To listObjectCount
            tableName = sh.ListObjects(i).Name
            tableSheetName = sh.Name
            tableRange = sh.ListObjects(i).Range.Cells.Address
            tableRowCount = sh.ListObjects(i).Range.Rows.Count
            tableColumnCount = sh.ListObjects(i).Range.Columns.Count
            
            '書込み処理
            write_IX = write_IX + 1
            
            ws.Cells(write_IX, 1) = tableName
            ws.Cells(write_IX, 2) = tableSheetName
            ws.Cells(write_IX, 3) = tableRange
            ws.Cells(write_IX, 4) = tableRowCount
            ws.Cells(write_IX, 5) = tableColumnCount
            
        Next
    Next

End Sub


処理手順
1Book内Sheetをループ
2ListObjectsの数だけループ
3WorkSheets(”テーブル一覧”)に書き込む

4 感想

テーブル機能はこれまでまったく使ってこなかったので、これからは使っていこうと思います!


ではでは、この辺で(^^)/~~~