「より高速な VBA マクロ」について

下記リンク先のページ
『 Excel 2007 におけるパフォーマンスの改善 』
の「より高速な VBA マクロ」についてのメモ

上記ページの該当箇所では
VBA マクロを高速化するための
５つの基本的なヒントとマクロの例が紹介されています。

５つの基本的なヒントを引用します。

１．マクロの実行中は、画面更新と計算を無効にします。
２．セル単位でループするのではなく、2 次元配列を含むバリアントで、範囲からの データを取得します。
３．Range オブジェクトなどの Excel オブジェクトは、選択したりアクティブ化する のではなく、直接的に参照します。
４．配列を Range に直接的に割り当てることにより、結果を返します。
５．マクロが終了した時点で、画面更新と計算を有効にします。

これらのヒントについて順に見ていきます。

１．マクロの実行中は、画面更新と計算を無効にします。

以下のコードで画面更新と計算を無効にできます。

'画面更新を無効
Application.ScreenUpdating = False
'計算を手動にする/計算を無効
Application.Calculation = xlCalculationManual

このコードをプロシージャの最初に実行すると
VBAであるセルの値を変えたときでも
シートやグラフの見た目は変化しません。

また、あるワークシート関数の参照元セルの値を変えても
自動で計算されません。

２．セル単位でループするのではなく、2 次元配列を含むバリアントで、範囲からの データを取得します。

ようするに
セルの範囲をバリアント型の変数にいれて使うということなので
これについては
以前の記事「 セルの値を配列に格納して使う 」を参照してください。

３．Range オブジェクトなどの Excel オブジェクトは、選択したりアクティブ化する のではなく、直接的に参照します。

選択したり

Range("A1").select
ActiveCell.Value = 20

アクティブ化する

Range("A1").Activate
ActiveCell.Value = 20

のではなく直接的に参照します。

Range("A1") = 20

自分でVBAを直接作っていくと
こういったことはないと思いますが、
マクロ自動記録で作ったコードは
SelectとActivateは必ず多用されています。

４．配列を Range に直接的に割り当てることにより、結果を返します。

これについても
以前の記事「 セルの値を配列に格納して使う 」を参照してください。

５．マクロが終了した時点で、画面更新と計算を有効にします。

以下のコードで画面更新と計算を有効にできます。

'画面更新を有効
Application.ScreenUpdating = True
'計算を自動にする/計算を有効
Application.Calculation = xlCalculationAutomatic

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual と
対にして使います。

サンプルコードはこちら

Sub macro101225a()
'Option Base 1で実行
'「より高速な VBA マクロ」サンプルコード

    Dim i As Integer
   
    '画面更新と計算を無効
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
   
    'Variant型の変数と出力用配列を宣言する
    Dim vData As Variant
    Dim dOutput() As String

    'バリアントで、範囲からのデータを取得
    vData = Range("A1:A5") '5x1
   
    '出力用の配列のサイズを指定
    ReDim dOutput(UBound(vData, 1), 1) '5x1
   
    'Variant型の変数に入れた値を処理して出力用配列に入れる
    For i = 1 To UBound(vData, 1)
        'Chr関数で文字に変換
        dOutput(i, 1) = Chr(vData(i, 1))
    Next i
   
    '配列を Range に直接的に割り当てる
    Range("B1").Resize(UBound(dOutput, 1), 1) = dOutput '5x1

    
    '画面更新と計算を有効
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
   
End Sub

上のコードを下の状態のシートで実行する。

実行後のシート

数字をChr関数で文字にしました。

脳トレ計算

某有名ゲームの簡単な計算問題を
VBAでやります。

最近、脳みその活動レベルが低下しているなと
自覚している人にお薦めです。
２桁対１桁の計算をしたときに
脳みそがシュワシュワするのを感じました。

まずは準備です。
コードはこちら

Sub macro101218z()
'macro101218系準備

    Sheets.Add.Name = "結果"
    With Sheets("結果")
        .Cells(1, 1) = "x"
        .Cells(1, 2) = "Ope"
        .Cells(1, 3) = "y"
        .Cells(1, 4) = "="
        .Cells(1, 5) = "回答"
        .Cells(1, 6) = "正誤"
        .Cells(1, 7) = "時間"
        .Cells(1, 8) = "所要時間(秒)"
        .Cells(2, 11) = "回答問題数"
        .Cells(3, 11) = "総所要時間(秒)"
        .Cells(4, 11) = "平均所要時間(秒)"
        .Cells(5, 11) = "正解率"
    End With
   
   
    Sheets.Add.Name = "問題"
    ActiveSheet.Cells.Interior.ColorIndex = 2
    With ActiveSheet.Cells(20, 10).Borders
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = 1
    End With
   
    ActiveSheet.OLEObjects.Add(ClassType:="Forms.CommandButton.1", Link:=False _
        , DisplayAsIcon:=False, Left:=600.75, Top:=217.5, Width:=64.5, Height _
        :=24).Select
    ActiveSheet.OLEObjects.Item(1).Object.Caption = "開始"
    Randomize
   
End Sub

上のコードを実行すると
”問題”と”結果”の２つのシートが作成されます。

”問題”のシートにはボタンを作成してあります。
このままではボタンを押しても何も実行されませんので、
次のプロシージャを
”問題”シートのオブジェクトモジュールに
コピペしてください。

Private Sub CommandButton1_Click()
'スタート

    Randomize    ' 乱数発生ルーチンを初期化します。
    Call macro101218b '前回のデータ削除
    Sheets("結果").Range("G2") = Now '開始時間
    Call macro101218a '出題
   
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Column <> Range("J20").Column Then Exit Sub
    If Target.Row <> Range("J20").Row Then Exit Sub
   
    Dim MyTime As Date
    MyTime = Now
   
    Dim sh1 As Object
    Set sh1 = ActiveWorkbook.Sheets("問題")
   
    With Sheets("結果")
        .Range("A2:H2").Insert shift:=xlDown
        .Range("G2") = MyTime '回答時間
        .Range("G2").NumberFormatLocal = "hh:mm:ss"
        '所要時間（秒）
        .Range("H2") = (.Range("G2") - .Range("G3")) * 86400
    End With
   
    '正誤の確認
    Dim x As Integer
    Dim y As Integer
    Dim Ans As Integer
    x = sh1.Cells(20, 6).Value
    y = sh1.Cells(20, 8).Value
    Ans = sh1.Cells(20, 10)
    sh1.Cells(20, 11).Font.Size = 24
    sh1.Cells(20, 11).Font.ColorIndex = 3
   
    Select Case sh1.Cells(20, 7)
        '演算子で分岐
        Case "＋"
            If x + y = Ans Then
                sh1.Cells(20, 11) = "正解"
            Else
                sh1.Cells(20, 11) = "不正解"
                Beep
            End If
        Case "－"
            If x - y = Ans Then
                sh1.Cells(20, 11) = "正解"
            Else
                sh1.Cells(20, 11) = "不正解"
                Beep
            End If
        Case "×"
            If x * y = Ans Then
                sh1.Cells(20, 11) = "正解"
            Else
                sh1.Cells(20, 11) = "不正解"
                Beep
            End If
        Case "÷"
            If x / y = Ans Then
                sh1.Cells(20, 11) = "正解"
            Else
                sh1.Cells(20, 11) = "不正解"
                Beep
            End If
    End Select
   
    With Sheets("結果")
        .Range("A2:F2") = Range("F20:K20").Value '問題を結果シートに
        .Range("L2") = .Range("A1").End(xlDown).Row - 1 '問題数
        .Range("L3") = (.Range("G2") - .Range("G1").End(xlDown)) * 24 * 60 * 60 '所要時間
        .Range("L4") = .Range("L3") / .Range("L2") '平均所要時間
       
        '正解率
        Dim c As Integer
        Dim i As Integer
        For i = 2 To .Range("G1").End(xlDown).Row
            If .Cells(i, 6) = "正解" Then
                c = c + 1
            End If
        Next i
        .Range("L5") = c / .Range("L2") * 100 & "%"
        .Columns.AutoFit
    End With
   
    Application.Wait Now + TimeValue("00:00:01")
    '次の問題へ
    sh1.Range("F20:K20") = ""
    Call macro101218a
   
End Sub

次が計算問題実行する本体などのプロシージャです。

Sub macro101218b()
'結果シートをクリア

    With Sheets("結果")
        .Range("A2:H" & Rows.count).Clear
        .Range("L2:L5").Clear
    End With
   
End Sub
Sub macro101218a()
'脳トレ計算

    Dim x As Integer, y As Integer
    Dim ketaX As Integer, ketaY As Integer
    Dim OpeIndex As Integer
    Dim Ope(4) As String
    Ope(1) = "＋"
    Ope(2) = "－"
    Ope(3) = "×"
    Ope(4) = "÷"
   
    'xとyの桁数
    ketaX = 2
    ketaY = 1
   
    'x,y,演算子を決定
    OpeIndex = Int(4 * Rnd) + 1
    x = Int(10 ^ ketaX * Rnd)
    y = Int(10 ^ ketaY * Rnd)
   
    '割り算の場合
    If OpeIndex = 4 Then
        '0以外で割り算のときyを割り切れる数にする
        Do While y = 0
            y = Int(10 * Rnd)
        Loop
        Do While x Mod y <> 0
            y = Int(10 * Rnd)
            Do While y = 0
                y = Int(10 * Rnd)
            Loop
        Loop
    End If
   
    '問題を出力
    With Sheets("問題")
        .Range("F20:J20").Font.Size = 24
        .Cells(20, 6) = x
        .Cells(20, 7) = Ope(OpeIndex)
        .Cells(20, 8) = y
        .Cells(20, 9) = "＝"
        Range("F20:I20").Columns.AutoFit
        .Cells(20, 10).Select
       
    End With
   
End Sub

これで”問題”シートの「開始」ボタンを押すと
計算問題を開始できます。

それぞれのコードは単純なので
大体の流れだけ説明します。

まず最初に「開始」ボタンを押すと、
”問題”シートのオブジェクトモジュールの
CommandButton1_Click が実行されます。

この中で
開始時間が”結果”シートに記録され、
macro101218b で前回のデータ削除、
macro101218a で出題されます。

回答の正誤判定は
macro101218a で選択されたセルJ20に
答えを入力すると自動的にされます。

これはWorksheetのChangeイベントで発動します。
WorksheetのChangeイベントは該当シートの
どこかのセルの値が変わったときに発生します。

今は回答用のセルJ20以外は
Ifステートメントで判別して無視しています。

回答の正誤判定が終わったら
問題と回答、正誤判定を”結果”シートにも入れます。
簡単な統計を計算して表示します。

これで1回の計算が終わり、次の計算が出題されます。

問題の回数は任意です。
好きなだけ連続してできます。

2回目に計算を連続してするときに
「開始」ボタンを押してください。

「開始」ボタンを押さないと
所要時間に何もしていない時間まで含められて
時間が正確にでません。

実行の様子： ”問題”シート

”結果”シート

なかなかハマります。

素数を調べる

素数とは
1とその数自身でしか割り切れない数です。

まずは2から a までの正数に含まれる素数を調べます。
下のコードでは、a = 1000で
2から1000までの正数に含まれる素数を調べています。

大まかな考え方は次のようになっています。

ある正数 i を
2から i までの正数 j で順に割っていく。
余りが0、つまり割り切れたとき
i <> j ならば、i は i 以外の数で割り切れたので素数でない、
i = j ならば、i は素数。

コードはこちら

Sub macro101211a()
'素数を調べる

    Sheets.Add.Name = "macro101212a"
    Cells(1, 1) = "素数"
   
    Dim i As Long, j As Long
    Dim a As Long
   
    '2からaまでの正数を調べる
    a = 1000
   
    For i = 2 To a
        For j = 2 To i
            If (i Mod j) = 0 Then
                If i = j Then
                    'iは素数
                    Rows(2).Insert
                    Cells(2, 1) = i
                Else
                    '1とその数以外で割り切れる場合
                    'その数(i)は素数でないので
                    '次の数へ
                    GoTo NextNum
                End If
            End If
        Next j
NextNum:
    Next i

End Sub

実行後のシート

次はある正数を素因数分解したいと思います。
素因数分解とは次のようなことです。

18 = 2 * 3 * 3

大まかな考え方は次のようになっています。

ある正数 x を
2から x までの正数 i で順に割っていき
一番最初に割り切れる i が素因数。
x をその i で割って商が1でないなら
x = x / i にして
再度2から x までの正数 i で順に割っていき
素数を調べる。
これをx = 1になるまで繰り返す。

コードはこちら

Sub macro101211b()
'Option Base 1で実行
'素数に分解して
'その素数を配列に入れる

    Dim i As Long
    Dim x As Long '素数に分解する正数(>=2)
    Dim x2 As Long '操作用のｘ
    Dim count As Integer '配列の添え字用
    Dim PNum() As Long '素数を入れる配列
    Dim Str As String
    count = 1
    x = 18
    x2 = x
   
ReStart:
    For i = 2 To x2
        If x2 Mod i = 0 Then
            'iはxの素数
            ReDim Preserve PNum(count)
            PNum(count) = i
            x2 = x2 / i
            count = count + 1
            GoTo ReStart
        End If
    Next i
   
    '結果出力用文字列作成
    Str = x & " = "
    For i = 1 To UBound(PNum)
        Str = Str & PNum(i) & " * "
    Next i
    Str = Left(Str, Len(Str) - 3)
    MsgBox Str
   
End Sub

実行結果例

素因数分解までしたら
最大公約数、最小公倍数を調べます。

まずは、素因数分解の仕方を上のプロシージャから変更して
同じ素数の掛け合わせは累乗で表現します。

たとえば18なら2*3^2なので
次のように表現します。

素数	指数
2	1
3	2

２つの数の最大公約数、最小公倍数ですので
素数、1つ目の数の指数、2つ目の数の指数の順に並べます。

最大公約数は
２つの数に共通でない素因数は捨て、
２つの数の共通な素因数の次数の低いものを掛け合わせたもの。

また、最小公倍数は
２つの数に共通でない素因数はそのまま取り、
共通な素因数はその次数の高いものを選んで掛け合わせたもの。

この定義から最大公約数、最小公倍数を求める大まかな流れを考えます。

最大公約数は
2つの数の指数が共に0でないとき
小さいほうの指数を取って
該当する素因数を累乗したものを掛けていく。

最小公倍数は
2つの数の指数の大きいほうの指数を取って
該当する素因数を累乗したものを掛けていく。

２つの数に共通でない素因数の場合も
０か１以上の比較なので
単純に大きいほうを取っていけばよい。

コードはこちら

Sub macro101211c()
'Option Base 1で実行
'素数に分解して
'その素数を配列に入れる
    Sheets.Add.Name = "macro101211c"
    Dim i As Integer
    Dim j As Integer
    Dim a As Integer
    Dim x(2) As Integer '素数に分解する正数(>=2)
    Dim x2 As Integer '操作用のｘとy
    Dim count As Integer '配列の添え字用
    Dim PNum(20, 3) As Integer '素数を入れる配列
        '素数の種類は20まで対応
    Dim Str As String '結果出力用文字列
    Dim GCM As Integer '最大公約数
    Dim LCM As Integer '最大公倍数
    count = 1
    x(1) = 42
    x(2) = 135
   
    For a = 1 To 2
        x2 = x(a)
Step1:
        For i = 2 To x2
            If x2 Mod i = 0 Then
                'iはxの素数
                For j = 1 To UBound(PNum, 1)
                    If i = PNum(j, 1) Then
                        PNum(j, a + 1) = PNum(j, a + 1) + 1
                        GoTo Step2
                    End If
                Next j
                PNum(count, 1) = i
                PNum(count, a + 1) = 1
                count = count + 1
Step2:
                x2 = x2 / i
                If x2 <> 1 Then
                    GoTo Step1
                End If
            End If
        Next i
    Next a
   
    '最大公約数
    GCM = 1
    LCM = 1
    For j = 1 To UBound(PNum, 1)
        If PNum(j, 1) <> 0 Then
            If PNum(j, 2) <> 0 And PNum(j, 3) <> 0 Then
                If PNum(j, 2) < PNum(j, 3) Then
                    GCM = GCM * PNum(j, 1) ^ PNum(j, 2)
                Else
                    GCM = GCM * PNum(j, 1) ^ PNum(j, 3)
                End If
            End If
        Else
            GoTo Step3
            '素数の列が0になったところで終わり
        End If
    Next j

Step3:
    '最小公倍数
    For j = 1 To UBound(PNum, 1)
        If PNum(j, 1) <> 0 Then
            If PNum(j, 2) > PNum(j, 3) Then
                LCM = LCM * PNum(j, 1) ^ PNum(j, 2)
            Else
                LCM = LCM * PNum(j, 1) ^ PNum(j, 3)
            End If
        Else
            GoTo Step4
            '素数の列が0になったところで終わり
        End If
    Next j

Step4:
    'シートに書き出す
    Cells(1, 1) = "素数"
    Cells(1, 2) = "x(1) = " & x(1)
    Cells(1, 3) = "x(2) = " & x(2)
    Range("A2").Resize(UBound(PNum, 1), UBound(PNum, 2)) = PNum
    Cells(1, 4) = "最大公約数"
    Cells(1, 5) = "最小公倍数"
    Cells(2, 4) = GCM
    Cells(2, 5) = LCM
   
End Sub

実行後のシートの例

手間は増えますが慣れる為に、
シートを使わず
配列を使うように心がけています。

Webクエリを秒単位で更新する

Webクエリを自動で更新するには
[外部データ範囲のプロパティ]-[更新の周期]に
チェックをいれて有効にしてから
60分から1分の間で更新の周期を指定します。

1分未満で更新するには
VBAを使用します。

まずはWebクエリを作成します。

例として下のコードで作成するWebクエリを使用します。
下のコードは手動でWebクエリを作成したときに
マクロ自動記録したものです。

テキトーに
47ニュースのWebページの株価の部分を取り込みます。
この株価の更新間隔は1分以上だと思うので
この株価を秒単位を取り込む意味はないです。

Sub macro101204a()
'Webクエリ作成

    Sheets.Add.Name = "macro101204"
    With Sheets("macro101204").QueryTables.Add     (Connection:="URL;http://www.47news.jp/", _
        Destination:=Range("A1"))
        .Name = "クエリ1"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .WebSelectionType = xlSpecifiedTables
        .WebFormatting = xlWebFormattingNone
        .WebTables = "2"
        .WebPreFormattedTextToColumns = True
        .WebConsecutiveDelimitersAsOne = True
        .WebSingleBlockTextImport = False
        .WebDisableDateRecognition = False
        .Refresh BackgroundQuery:=False
    End With
   
End Sub

このWebクエリをVBAで更新するには
次のようにします。

Sub macro101204b()
'Webクエリを更新する

    Sheets("macro101204").QueryTables("クエリ1").Refresh
   
End Sub

上のプロシージャを秒単位で実行すれば
Webクエリの秒単位の更新ができます。

これにはOnTimeメソッドを使います。

下のプロシージャでは10秒間隔で更新するように
OnTimeメソッドでmacro101204cを実行する時間を

Now + TimeValue("00:00:10")

で指定して、
現在 + 10秒に実行、つまり
10秒後に実行するようにしています。

TimeValue関数の引数を変更すれば
その他の間隔で更新できます。
もちろん、分単位でも時間単位でも指定できます。

実際は、Webクエリの更新は
簡単なデータでも時間が掛かるので
1秒単位での更新などは無理があると思います。

コードはこちら

Sub macro101204c()
'Webクエリを更新する
'秒単位で更新する

    Debug.Print Now & "　クエリ1を更新します。"
    Sheets("macro101204").QueryTables("クエリ1").Refresh
   
    Application.OnTime _
        Now() + TimeValue("00:00:10"), "macro101204c"
   
End Sub

Webクエリを更新したら
そのデータを違うシートにコピペして
時系列データにしたりなど
更新するたびに実行したい処理があります。

そんな場合は
RefreshメソッドとOnTimeメソッドの間で
更新するたびに実行したい処理をいれます。

Refreshメソッドを
BackgroundQuery:=False にすると
クエリの更新が終わるまで
Refreshメソッドの次のコードは実行されません。

したがって
更新する前のデータをコピペすることがなくなります。

コードはこちら

Sub macro101204d()
'Webクエリを更新する
'秒単位で更新する

    Debug.Print Now & "　クエリ1を更新します。"
    Sheets("macro101204").QueryTables("クエリ1").Refresh

BackgroundQuery:=False
   
    '更新のたびに実行したい処理
    With Sheets("macro101204")
        .Rows(10).Insert
        .Cells(10, 1) = Now
        .Cells(10, 1).NumberFormatLocal = "hh:mm:ss"
        .Cells(10, 2) = Cells(1, 2)
        .Cells(10, 3) = Cells(2, 2)
        .Cells(10, 4) = Cells(4, 2)
        .Cells(10, 5) = Cells(5, 2)
        .Cells(10, 6) = Cells(6, 2)
    End With
   
    Application.OnTime _
        Now() + TimeValue("00:00:10"), "macro101204d"

End Sub

このようになります。

実用的には
インターネットが接続されていなくて
Webクエリが更新できない場合の対応など必要です。