アフィリエイト・アドセンス広告を利用しています。詳細は こちら



Excel VBA - 配列と Select Case ステートメントを使ったシート・セル操作メモ

Excel VBA で配列と Select Case ステートメントを使ったシート・セル操作する VBA コードを公開します。

シートを参照することなく VBA コードの実行だけでシートを作成・操作できるため、今回の記事にはサンプルファイルの公開はありません。

Excel と Excel Visual Basic Editor(VBE)の環境設定については 以前公開した記事 より、VBA コードの基本的な内容については こちらの記事 よりご確認ください。

Excel VBA - 配列と Select Case ステートメントを使ったシート・セル操作メモ


配列と Select Case ステートメントを使ったシート・セル操作 VBA サンプルコード 1

以下、配列と Select Case ステートメントを使ったシート・セル操作 VBA サンプルコード 1 です。

この VBA コードは配列に作成・操作したいシート名と各シートのセルに代入したい文字列をあらかじめ設定をして、For 文と If 文と Select Case ステートメントを組み合わせることで、シートの作成・設定と各シートのセルへ文字列の代入を行うことができます。

ちなみにこの VBA は自作関数 GetArrFromRange を使っているためコード単体では動作しません。別途自作関数 GetArrFromRange を設定する必要があります。(関連記事 1関連記事 2

次のセクション から配列と Select Case ステートメントを使ったシート・セル操作 VBA コード部分について内容を説明します。

2023/11/12 追記

以下の VBA コードにはメモリリークを起こす可能性があります。詳細は こちら

こちら でメモリリークを対策した VBA コードを公開します。

Option Explicit

Sub ArraySelectCaseMultipleSheets1()
  ' Array 関数にシート名を設定、シートを追加・操作する処理
  ' for 文と Select Case ステートメントを使い各シート別にコード実行

  ' 実行速度計測開始
  Dim starttime As Double
  starttime = Timer

' ----------

  ' カウンタ用変数(一見見分けにくい文字同士を組み合わせない形、i と j、m と n、o(オー) と 0(ゼロ))
  Dim i As Long, k As Long

' ----------

  ' 配列に処理対象のシート名設定
  Dim sheetname() As Variant ' シート名格納用 1次元配列の変数宣言
  sheetname = Array("テスト追加シート1", "テスト追加シート2", "テスト追加シート3") ' Array 関数の要素に対象シート名代入

' ----------

  ' シート名重複判定用ブール型変数宣言
  Dim flag As Boolean
  flag = False ' 初期化

  ' 配列 sheetname に代入したシート名が既存のシート名と重複するかどうか判定
  ' 重複していた場合は既存の同名シートを削除、処理の最後に配列 sheetname のシート名を新規作成
  For i = LBound(sheetname) To UBound(sheetname) ' 配列 sheetname の最大要素までループ処理
    For k = 1 To Sheets.Count ' 既存のシート名取得のため、変数 k に 1 からシート数までループ処理
      If Sheets(k).Name = sheetname(i) Then ' 配列 sheetname の i 番目のシート名が、k 番目の既存のシート名と一致した場合
        flag = True ' ブール型変数に重複判定用として True を代入
      End If
    Next k

    ' 重複判定があった既存のシート名を削除
    If flag = True Then ' 重複判定用ブール型変数に True があった場合
      Application.DisplayAlerts = False ' 確認メッセージオフ
      Worksheets(sheetname(i)).Delete ' i 番目の既存のシート名を削除
      Application.DisplayAlerts = True ' 確認メッセージオン
    End If

    ' 配列 sheetname の i 番目のシート名を新規作成
    Sheets.Add(, Sheets(Sheets.Count)).Name = sheetname(i)

    flag = False ' 初期化

  Next i

' ----------

  ' 変数宣言
  Dim ws As Worksheet ' シート格納用オブジェクト変数宣言
  Dim items() As Variant ' 項目名格納用 1次元配列の変数宣言
  Dim data() As Variant ' 項目名を代入するセル範囲指定用動的配列宣言

  For i = LBound(sheetname) To UBound(sheetname) ' 配列 sheetname の最大要素までループ処理
  
    Set ws = ThisWorkbook.Worksheets(sheetname(i)) ' 配列 sheetname の i 番目シートをオブジェクト変数にセット
  
    Select Case i

    Case 0 ' 配列 sheetname(0) - テスト追加シート1

      ' Array 関数の要素に項目名代入
      items = Array("項目名1", "項目名2", "項目名3", "項目名4", "項目名5", "項目名6")

      ' 配列 Item 最大要素 + 1 までを Range で範囲指定、配列として動的配列にセット
      data = GetArrFromRange.GetArrFromRange(ws.Range(ws.Cells(1, 1), ws.Cells(1, UBound(items) + 1)))

      ' 1次元配列のデータを 2次元配列に代入
      For k = LBound(items) To UBound(items) ' 配列 items の最大要素までループ処理
        data(1, k + 1) = items(k) ' 配列 items の k 番目のデータを、配列 data の 1 行目 k + 1 列目に格納
      Next k

      ' 2次元配列 data の内容を、Range で指定したセルから Resize で範囲を変更してセルに代入
      ws.Range("A1").Resize(UBound(data, 1), UBound(data, 2)).Value = data

    Case 1 ' 配列 sheetname(1) - テスト追加シート2

      items = Array("項目名7", "項目名8", "項目名9", "項目名10")

      data = GetArrFromRange.GetArrFromRange(ws.Range(ws.Cells(1, 1), ws.Cells(1, UBound(items) + 1)))

      For k = LBound(items) To UBound(items)
        data(1, k + 1) = items(k)
      Next k

      ws.Range("A1").Resize(UBound(data, 1), UBound(data, 2)).Value = data

    Case 2 ' 配列 sheetname(2) - テスト追加シート3

      items = Array("項目名11", "項目名12", "項目名13", "項目名14", "項目名15")

      data = GetArrFromRange.GetArrFromRange(ws.Range(ws.Cells(1, 1), ws.Cells(1, UBound(items) + 1)))

      For k = LBound(items) To UBound(items)
        data(1, k + 1) = items(k)
      Next k

      ws.Range("A1").Resize(UBound(data, 1), UBound(data, 2)).Value = data

    End Select

    ' 配列 sheetname の i 番目シート 1行目を中央揃え(水平位置)に設定
    Worksheets(sheetname(i)).Rows(1).HorizontalAlignment = xlCenter
    ' 配列 sheetname の i 番目シートすべてのセルのフォントサイズ 8 に設定
    Worksheets(sheetname(i)).Cells.Font.Size = 8
    ' 配列 sheetname の i 番目シートすべての列幅を自動調整
    Worksheets(sheetname(i)).Columns.EntireColumn.AutoFit

  Next i

' ----------

  ' 実行速度計測結果表示
  Debug.Print Format(Timer - starttime, "0.00秒")

End Sub

配列にシート名を設定してシート新規作成

  ' 配列に処理対象のシート名設定
  Dim sheetname() As Variant ' シート名格納用 1次元配列の変数宣言
  sheetname = Array("テスト追加シート1", "テスト追加シート2", "テスト追加シート3") ' Array 関数の要素に対象シート名代入

' ----------

  ' シート名重複判定用ブール型変数宣言
  Dim flag As Boolean
  flag = False ' 初期化

  ' 配列 sheetname に代入したシート名が既存のシート名と重複するかどうか判定
  ' 重複していた場合は既存の同名シートを削除、処理の最後に配列 sheetname のシート名を新規作成
  For i = LBound(sheetname) To UBound(sheetname) ' 配列 sheetname の最大要素までループ処理
    For k = 1 To Sheets.Count ' 既存のシート名取得のため、変数 k に 1 からシート数までループ処理
      If Sheets(k).Name = sheetname(i) Then ' 配列 sheetname の i 番目のシート名が、k 番目の既存のシート名と一致した場合
        flag = True ' ブール型変数に重複判定用として True を代入
      End If
    Next k

    ' 重複判定があった既存のシート名を削除
    If flag = True Then ' 重複判定用ブール型変数に True があった場合
      Application.DisplayAlerts = False ' 確認メッセージオフ
      Worksheets(sheetname(i)).Delete ' i 番目の既存のシート名を削除
      Application.DisplayAlerts = True ' 確認メッセージオン
    End If

    ' 配列 sheetname の i 番目のシート名を新規作成
    Sheets.Add(, Sheets(Sheets.Count)).Name = sheetname(i)

    flag = False ' 初期化

  Next i

配列にシート名を設定してシートをまとめて新規作成します。既存のシート名と名前が被った場合はシート追加時にエラーとなるため、既存のシート名があるかどうかチェック、あれば削除してから新規作成を行うようにしています。

19行目にシート名格納用配列を宣言して、20行目に Array 関数を使って各要素に新規作成用のシート名を代入します。

25行目にシート名重複判定用のブール型変数を宣言して 26行目で Flase を代入して初期化します。(変数を宣言した時点ですでに False が既定値となりますが、混乱を避けるために一応明示的に初期値を設定しています)

30行目に For 文とカウンタ変数、LBound 関数と UBound 関数を組み合わせて、シート名を格納した 1次元配列 sheetname の最小~最大要素までループさせます。49行目までカウンタ変数 i の For 文が続くので、この間に既存シート名の重複チェックと新規作成をします。

31~35行目で配列 sheetname に代入したシート名が、既存のシート名と重複するかどうか判定する処理をします。

31行目に既存のシート名取得のため Sheets.Count を使って、カウンタ変数 k に 1 からシート数分ループ処理をします。

32行目で配列 sheetname の i 番目のシート名が、k 番目(Sheets(k).Name)の既存のシート名と一致した場合、33行目でシート名重複判定用ブール型変数に True をセットします。一致しなかった場合は 26行目および 47行目に代入した初期値 False のままです。

38行目でシート名重複判定用ブール型変数が True だった場合、39~41行目で既存シートの削除処理を行います。

以下の参考サイトの内容通りに、Application オブジェクトの DisplayAlerts プロパティ(Application.DisplayAlerts)と Worksheet オブジェクトの Delete メソッド(Worksheets(sheetname(i)).Delete)を使ってシートを削除します。

45行目で配列 sheetname のカウンタ変数 i 番目にあるシート名がない状態にしてから、配列 sheetname のカウンタ変数 i 番目に格納した文字列を、Worksheets コレクションの Add メソッドの Name プロパティ(Sheets.Add(, Sheets(Sheets.Count)).Name)に代入してシート名を作成します。

繰り返し処理をするため次のループ処理に入る前に、47行目でシート名重複判定用ブール型変数を False で初期化しておきます。

これを 30~49行目のループ処理とカウンタ変数 i を使って配列 sheetname の要素数分繰り返すことで、シートの新規作成を行うことができます。

シート設定と各シートのセルに配列に格納した文字列を代入(Select Case ステートメントの処理順をカウンタ変数を使って制御)

  ' 変数宣言
  Dim ws As Worksheet ' シート格納用オブジェクト変数宣言
  Dim items() As Variant ' 項目名格納用 1次元配列の変数宣言
  Dim data() As Variant ' 項目名を代入するセル範囲指定用動的配列宣言

  For i = LBound(sheetname) To UBound(sheetname) ' 配列 sheetname の最大要素までループ処理
  
    Set ws = ThisWorkbook.Worksheets(sheetname(i)) ' 配列 sheetname の i 番目シートをオブジェクト変数にセット
  
    Select Case i

    Case 0 ' 配列 sheetname(0) - テスト追加シート1

      ' Array 関数の要素に項目名代入
      items = Array("項目名1", "項目名2", "項目名3", "項目名4", "項目名5", "項目名6")

      ' 配列 Item 最大要素 + 1 までを Range で範囲指定、配列として動的配列にセット
      data = GetArrFromRange.GetArrFromRange(ws.Range(ws.Cells(1, 1), ws.Cells(1, UBound(items) + 1)))

      ' 1次元配列のデータを 2次元配列に代入
      For k = LBound(items) To UBound(items) ' 配列 items の最大要素までループ処理
        data(1, k + 1) = items(k) ' 配列 items の k 番目のデータを、配列 data の 1 行目 k + 1 列目に格納
      Next k

      ' 2次元配列 data の内容を、Range で指定したセルから Resize で範囲を変更してセルに代入
      ws.Range("A1").Resize(UBound(data, 1), UBound(data, 2)).Value = data

    Case 1 ' 配列 sheetname(1) - テスト追加シート2

      items = Array("項目名7", "項目名8", "項目名9", "項目名10")

      data = GetArrFromRange.GetArrFromRange(ws.Range(ws.Cells(1, 1), ws.Cells(1, UBound(items) + 1)))

      For k = LBound(items) To UBound(items)
        data(1, k + 1) = items(k)
      Next k

      ws.Range("A1").Resize(UBound(data, 1), UBound(data, 2)).Value = data

    Case 2 ' 配列 sheetname(2) - テスト追加シート3

      items = Array("項目名11", "項目名12", "項目名13", "項目名14", "項目名15")

      data = GetArrFromRange.GetArrFromRange(ws.Range(ws.Cells(1, 1), ws.Cells(1, UBound(items) + 1)))

      For k = LBound(items) To UBound(items)
        data(1, k + 1) = items(k)
      Next k

      ws.Range("A1").Resize(UBound(data, 1), UBound(data, 2)).Value = data

    End Select

    ' 配列 sheetname の i 番目シート 1行目を中央揃え(水平位置)に設定
    Worksheets(sheetname(i)).Rows(1).HorizontalAlignment = xlCenter
    ' 配列 sheetname の i 番目シートすべてのセルのフォントサイズ 8 に設定
    Worksheets(sheetname(i)).Cells.Font.Size = 8
    ' 配列 sheetname の i 番目シートすべての列幅を自動調整
    Worksheets(sheetname(i)).Columns.EntireColumn.AutoFit

  Next i

Select Case ステートメントを使ってシート別の各セルに指定の文字列を代入します。

54~56行目にシート格納用オブジェクト変数とセル代入用の配列を宣言しています。

58行目に For 文とカウンタ変数、LBound 関数と UBound 関数を組み合わせて、シート名を格納した 1次元配列 sheetname の最小~最大要素までループさせます。113行目までカウンタ変数 i の For 文が続くので、この間に Select Case ステートメントを使って各シートのセルに指定の文字列を代入するようにコントロールしています。

60行目で WorkSheet オブジェクト変数と Set ステートメントを使って、WorkSheet オブジェクトで配列 sheetname のカウンタ変数 i 番目にあるシート名を指定します。以降の Select Case ステートメントではこのオブジェクト変数を使ってシート名を指定します。

62行目の Select Case ステートメントを使い条件分岐を設定します。ここではカウンタ変数 i を条件分岐に指定します。

64行目、80行目、92行目それぞれの Case 節ではカウンタ変数 i の値を直接指定します。このカウンタ変数 i は 58行目の配列 sheetname の最小から最大要素までインクリメントして 0~2 までの値が代入されるので、その値に応じた処理を Case 節で分けています。どの Case 節とも一致しない場合は、104行目の End Select まで飛び次の行に処理を移します。

64~102行目にある Case 節に分けられた処理となっていますが中身は同じです。違う点は配列 items に代入する Array 関数を使った文字列(シート別セルに代入する文字列)だけとなっています。ここでは 64~78行目までの Case 節(Case 0)を例に内容を説明します。

67行目で Array 関数を使ってセルに代入したい文字列を設定して配列 items に代入します。

70行目で自作関数 GetArrFromRange を使って配列 items の各要素を代入するセルの 2次元配列を作成します。(関連記事 1関連記事 2

73行目に For 文とカウンタ変数、LBound 関数と UBound 関数を組み合わせて、1次元配列 items の最小~最大要素までループさせます。71行目で配列 items のカウンタ変数 k 番目にある文字列を、2次元配列 data の 1行 k(カウンタ変数 k)+ 1 列目に格納します。(カウンタ変数 k に + 1 をしているのは、k が 0(配列 items の最小要素番号)からスタートするため + 1 で調整しているため)

78行目で 2次元配列 data に代入された配列 items の内容を、指定したシートのセル範囲に一気に転記しています。

以上の流れを Select Case ステートメントの Case 節に分けることで、シート別に応じた処理を実行することができます。

104行目以降は以下のサイトを参考に WorkSheet オブジェクトを使って各シートを一括調整しています。各シートのフォーマットを統一することができます。

配列と Select Case ステートメントを使ったシート・セル操作 VBA サンプルコード 2

以下、配列と Select Case ステートメントを使ったシート・セル操作 VBA サンプルコード 2 です。

こちらの VBA コードは VBA サンプルコード 1 に Select Case ステートメントの処理順を管理する配列を追加して制御させる内容となっています。そのため、その部分以外は VBA サンプルコード 1 の内容のままです。

こちらも VBA サンプルコード 1 と同様に自作関数 GetArrFromRange を使っているためコード単体では動作しません。別途自作関数 GetArrFromRange を設定する必要があります。(関連記事 1関連記事 2

次のセクションVBA サンプルコード 1 からの変更点について内容を説明します。

2023/11/12 追記

以下の VBA コードにはメモリリークを起こす可能性があります。詳細は こちら

こちら でメモリリークを対策した VBA コードを公開します。

Option Explicit

Sub ArraySelectCaseMultipleSheets2()
  ' Array 関数にシート名を設定、シートを追加・操作する処理
  ' for 文と Select Case ステートメントを使い各シート別にコード実行

  ' 実行速度計測開始
  Dim starttime As Double
  starttime = Timer

' ----------

  ' カウンタ用変数(一見見分けにくい文字同士を組み合わせない形、i と j、m と n、o(オー) と 0(ゼロ))
  Dim i As Long, k As Long

' ----------

  ' 配列に処理対象のシート名設定
  Dim sheetname() As Variant ' シート名格納用 1次元配列の変数宣言
  sheetname = Array("テスト追加シート4", "テスト追加シート5", "テスト追加シート6") ' Array 関数の要素に対象シート名代入

' ----------

  ' シート名重複判定用ブール型変数宣言
  Dim flag As Boolean
  flag = False ' 初期化

  ' 配列 sheetname に代入したシート名が既存のシート名と重複するかどうか判定
  ' 重複していた場合は既存の同名シートを削除、処理の最後に配列 sheetname のシート名を新規作成
  For i = LBound(sheetname) To UBound(sheetname) ' 配列 sheetname の最大要素までループ処理
    For k = 1 To Sheets.Count ' 既存のシート名取得のため、変数 k に 1 からシート数までループ処理
      If Sheets(k).Name = sheetname(i) Then ' 配列 sheetname の i 番目のシート名が、k 番目の既存のシート名と一致した場合
        flag = True ' ブール型変数に重複判定用として True を代入
      End If
    Next k

    ' 重複判定があった既存のシート名を削除
    If flag = True Then ' 重複判定用ブール型変数に True があった場合
      Application.DisplayAlerts = False ' 確認メッセージオフ
      Worksheets(sheetname(i)).Delete ' i 番目の既存のシート名を削除
      Application.DisplayAlerts = True ' 確認メッセージオン
    End If

    ' 配列 sheetname の i 番目のシート名を新規作成
    Sheets.Add(, Sheets(Sheets.Count)).Name = sheetname(i)

    flag = False ' 初期化

  Next i

' ----------

  ' 変数宣言
  Dim ws As Worksheet ' シート格納用オブジェクト変数宣言
  Dim items() As Variant ' 項目名格納用 1次元配列の変数宣言
  Dim data() As Variant ' 項目名を代入するセル範囲指定用動的配列宣言

  ' 変数宣言
  Dim selectadditems() As Variant ' Select Case で追加する項目名パターン値(Case の 0 ~ 2)を代入する 1次元配列の変数宣言
  selectadditems = Array(2, 0, 1) ' Array 関数の要素に適用させたい Select Case の項目名パターン値(Case の 0 ~ 2)を代入(要素数は配列 sheetname の要素数と必ず同じにする)

  For i = LBound(sheetname) To UBound(sheetname) ' 配列 sheetname の最大要素までループ処理
  
    Set ws = ThisWorkbook.Worksheets(sheetname(i)) ' 配列 sheetname の i 番目シートをオブジェクト変数にセット
  
    Select Case selectadditems(i)

    Case 0

      ' Array 関数の要素に項目名代入
      items = Array("項目名1", "項目名2", "項目名3", "項目名4", "項目名5", "項目名6")

      ' 配列 Item 最大要素 + 1 までを Range で範囲指定、配列として動的配列にセット
      data = GetArrFromRange.GetArrFromRange(ws.Range(ws.Cells(1, 1), ws.Cells(1, UBound(items) + 1)))

      ' 1次元配列のデータを 2次元配列に代入
      For k = LBound(items) To UBound(items) ' 配列 items の最大要素までループ処理
        data(1, k + 1) = items(k) ' 配列 items の k 番目のデータを、配列 data の 1 行目 k + 1 列目に格納
      Next k

      ' 2次元配列 data の内容を、Range で指定したセルから Resize で範囲を変更してセルに代入
      ws.Range("A1").Resize(UBound(data, 1), UBound(data, 2)).Value = data

    Case 1

      items = Array("項目名7", "項目名8", "項目名9", "項目名10")

      data = GetArrFromRange.GetArrFromRange(ws.Range(ws.Cells(1, 1), ws.Cells(1, UBound(items) + 1)))

      For k = LBound(items) To UBound(items)
        data(1, k + 1) = items(k)
      Next k

      ws.Range("A1").Resize(UBound(data, 1), UBound(data, 2)).Value = data

    Case 2

      items = Array("項目名11", "項目名12", "項目名13", "項目名14", "項目名15")

      data = GetArrFromRange.GetArrFromRange(ws.Range(ws.Cells(1, 1), ws.Cells(1, UBound(items) + 1)))

      For k = LBound(items) To UBound(items)
        data(1, k + 1) = items(k)
      Next k

      ws.Range("A1").Resize(UBound(data, 1), UBound(data, 2)).Value = data

    End Select

    ' 配列 sheetname の i 番目シート 1行目を中央揃え(水平位置)に設定
    Worksheets(sheetname(i)).Rows(1).HorizontalAlignment = xlCenter
    ' 配列 sheetname の i 番目シートすべてのセルのフォントサイズ 8 に設定
    Worksheets(sheetname(i)).Cells.Font.Size = 8
    ' 配列 sheetname の i 番目シートすべての列幅を自動調整
    Worksheets(sheetname(i)).Columns.EntireColumn.AutoFit

  Next i

' ----------

  ' 実行速度計測結果表示
  Debug.Print Format(Timer - starttime, "0.00秒")

End Sub

シート設定と各シートのセルに配列に格納した文字列を代入(Select Case ステートメントの処理順を配列を使って制御)

  ' 変数宣言
  Dim selectadditems() As Variant ' Select Case で追加する項目名パターン値(Case の 0 ~ 2)を代入する 1次元配列の変数宣言
  selectadditems = Array(2, 0, 1) ' Array 関数の要素に適用させたい Select Case の項目名パターン値(Case の 0 ~ 2)を代入(要素数は配列 sheetname の要素数と必ず同じにする)

  For i = LBound(sheetname) To UBound(sheetname) ' 配列 sheetname の最大要素までループ処理
  
    Set ws = ThisWorkbook.Worksheets(sheetname(i)) ' 配列 sheetname の i 番目シートをオブジェクト変数にセット
  
    Select Case selectadditems(i)

配列を使って Select Case ステートメントの処理順を制御するようにします。

59行目に Select Case ステートメント用の配列 selectadditems を宣言、60行目で Array 関数を使って Case 節の値を処理したい順番に配列 selectadditems に代入します。ここでは配列 sheetname の要素番号 0 ~ 2 の値を 2 → 0 → 1 の順にセットしています。

66行目の Select Case ステートメントの条件分岐で、カウンタ変数 i を使って配列 selectadditems の要素番号を指定することで、配列 selectadditems の各要素番号に格納してある値を参照することができます。

これにより Select Case ステートメントでは Case 2 → Case 0 → Case 1 の順番に処理をすることができます。

なお、配列 selectadditems に格納する sheetname の要素番号は同じ値を指定しても問題ありません。これにより同じ Case 節を繰り返し同じ処理をさせるといったことも可能です。

ちなみにわざわざ上記のような配列を使わなくても、直接 Case 節の値を書き換えてしまうことで処理順を変更することができます。ただ、Case 節が多くなると直接書き換えるのが面倒なうえ、間違えて意図しないエラーや結果が発生する原因にもなります。

そのような可能性が考えられる場合は、上記のような Case 節の処理順を管理する配列を用意したほうがいいかもしれません。

Excel VBA コードメモリリーク対策について

X(Twitter) にて教えてもらいましたが、LBound と UBound 関数を使用した VBA コードの書き方によってはメモリリークが起きる可能性があるようです。

ただ、指摘のあった関数による VBA コードのメモリリークについて日本語で言及している情報が少なく、今回公開した VBA コードが原因でメモリリークが起きるかどうか確認できていません。(こちらで単純にメモリリークに気づいていないというのもあります)

X(Twitter) で紹介してもらった こちらのサイト ではメモリリークする・しないコードの書き方が紹介されています。以下各セクションではこの書き方にならって、コード内容を書き直したメモリリーク対策版 VBA コードを公開します。

メモリリークが起きないとされているコード内容に修正しただけなので、実際にメモリリークが起きないかどうかまでは確認していません。

基本的に関数の返り値を一度変数に格納して、その変数を使用する方法に書き換えた内容となっています。各コードについて元の VBA コードから追加・変更した箇所をハイライトで表示しています。

配列と Select Case ステートメントを使ったシート・セル操作 VBA サンプルコード 1 メモリリーク対策版

Option Explicit

Sub ArraySelectCaseMultipleSheets1FixMemoryLeaks1() ' メモリリーク対策版
  ' Array 関数にシート名を設定、シートを追加・操作する処理
  ' for 文と Select Case ステートメントを使い各シート別にコード実行

  ' 実行速度計測開始
  Dim starttime As Double
  starttime = Timer

' ----------

  ' カウンタ用変数(一見見分けにくい文字同士を組み合わせない形、i と j、m と n、o(オー) と 0(ゼロ))
  Dim i As Long, k As Long

' ----------

  ' 配列に処理対象のシート名設定
  Dim sheetname() As Variant ' シート名格納用 1次元配列の変数宣言
  sheetname = Array("テスト追加シート1", "テスト追加シート2", "テスト追加シート3") ' Array 関数の要素に対象シート名代入

' ----------

  ' シート名重複判定用ブール型変数宣言
  Dim flag As Boolean
  flag = False ' 初期化

  ' LBound・UBound 関数格納用変数と代入(メモリリーク対策)
  Dim LB_sheetname As Variant, UB_sheetname As Variant
  LB_sheetname = LBound(sheetname)
  UB_sheetname = UBound(sheetname)

  ' 配列 sheetname に代入したシート名が既存のシート名と重複するかどうか判定
  ' 重複していた場合は既存の同名シートを削除、処理の最後に配列 sheetname のシート名を新規作成
  For i = LB_sheetname To UB_sheetname ' 配列 sheetname の最大要素までループ処理
    For k = 1 To Sheets.Count ' 既存のシート名取得のため、変数 k に 1 からシート数までループ処理
      If Sheets(k).Name = sheetname(i) Then ' 配列 sheetname の i 番目のシート名が、k 番目の既存のシート名と一致した場合
        flag = True ' ブール型変数に重複判定用として True を代入
      End If
    Next k

    ' 重複判定があった既存のシート名を削除
    If flag = True Then ' 重複判定用ブール型変数に True があった場合
      Application.DisplayAlerts = False ' 確認メッセージオフ
      Worksheets(sheetname(i)).Delete ' i 番目の既存のシート名を削除
      Application.DisplayAlerts = True ' 確認メッセージオン
    End If

    ' 配列 sheetname の i 番目のシート名を新規作成
    Sheets.Add(, Sheets(Sheets.Count)).Name = sheetname(i)

    flag = False ' 初期化

  Next i

' ----------

  ' 変数宣言
  Dim ws As Worksheet ' シート格納用オブジェクト変数宣言
  Dim items() As Variant ' 項目名格納用 1次元配列の変数宣言
  Dim data() As Variant ' 項目名を代入するセル範囲指定用動的配列宣言

  ' LBound・UBound 関数格納用変数(メモリリーク対策)
  Dim LB_items As Variant, UB_items As Variant
  Dim UB_data_1D As Variant, UB_data_2D As Variant

  For i = LB_sheetname To UB_sheetname ' 配列 sheetname の最大要素までループ処理
  
    Set ws = ThisWorkbook.Worksheets(sheetname(i)) ' 配列 sheetname の i 番目シートをオブジェクト変数にセット
  
    Select Case i

    Case 0 ' 配列 sheetname(0) - テスト追加シート1

      ' Array 関数の要素に項目名代入
      items = Array("項目名1", "項目名2", "項目名3", "項目名4", "項目名5", "項目名6")

      ' LBound・UBound 関数格納用へ代入(メモリリーク対策)
      LB_items = LBound(items)
      UB_items = UBound(items)

      ' 配列 Item 最大要素 + 1 までを Range で範囲指定、配列として動的配列にセット
      data = GetArrFromRange.GetArrFromRange(ws.Range(ws.Cells(1, 1), ws.Cells(1, UB_items + 1)))

      ' 1次元配列のデータを 2次元配列に代入
      For k = LB_items To UB_items ' 配列 items の最大要素までループ処理
        data(1, k + 1) = items(k) ' 配列 items の k 番目のデータを、配列 data の 1 行目 k + 1 列目に格納
      Next k

      ' LBound・UBound 関数格納用変数へ代入(メモリリーク対策)
      UB_data_1D = UBound(data, 1)
      UB_data_2D = UBound(data, 2)

      ' 2次元配列 data の内容を、Range で指定したセルから Resize で範囲を変更してセルに代入
      ws.Range("A1").Resize(UB_data_1D, UB_data_2D).Value = data

    Case 1 ' 配列 sheetname(1) - テスト追加シート2

      items = Array("項目名7", "項目名8", "項目名9", "項目名10")

      ' LBound・UBound 関数格納用変数へ代入(メモリリーク対策)
      LB_items = LBound(items)
      UB_items = UBound(items)

      data = GetArrFromRange.GetArrFromRange(ws.Range(ws.Cells(1, 1), ws.Cells(1, UB_items + 1)))

      For k = LB_items To UB_items
        data(1, k + 1) = items(k)
      Next k

      ' LBound・UBound 関数格納用変数へ代入(メモリリーク対策)
      UB_data_1D = UBound(data, 1)
      UB_data_2D = UBound(data, 2)

      ws.Range("A1").Resize(UB_data_1D, UB_data_2D).Value = data

    Case 2 ' 配列 sheetname(2) - テスト追加シート3

      items = Array("項目名11", "項目名12", "項目名13", "項目名14", "項目名15")

      ' LBound・UBound 関数格納用変数へ代入(メモリリーク対策)
      LB_items = LBound(items)
      UB_items = UBound(items)

      data = GetArrFromRange.GetArrFromRange(ws.Range(ws.Cells(1, 1), ws.Cells(1, UB_items + 1)))

      For k = LB_items To UB_items
        data(1, k + 1) = items(k)
      Next k

      ' LBound・UBound 関数格納用変数へ代入(メモリリーク対策)
      UB_data_1D = UBound(data, 1)
      UB_data_2D = UBound(data, 2)

      ws.Range("A1").Resize(UB_data_1D, UB_data_2D).Value = data

    End Select

    ' 配列 sheetname の i 番目シート 1行目を中央揃え(水平位置)に設定
    Worksheets(sheetname(i)).Rows(1).HorizontalAlignment = xlCenter
    ' 配列 sheetname の i 番目シートすべてのセルのフォントサイズ 8 に設定
    Worksheets(sheetname(i)).Cells.Font.Size = 8
    ' 配列 sheetname の i 番目シートすべての列幅を自動調整
    Worksheets(sheetname(i)).Columns.EntireColumn.AutoFit

  Next i

' ----------

  ' 実行速度計測結果表示
  Debug.Print Format(Timer - starttime, "0.00秒")

End Sub

配列と Select Case ステートメントを使ったシート・セル操作 VBA サンプルコード 2 メモリリーク対策版

Option Explicit

Sub ArraySelectCaseMultipleSheets2FixMemoryLeaks1() ' メモリリーク対策版
  ' Array 関数にシート名を設定、シートを追加・操作する処理
  ' for 文と Select Case ステートメントを使い各シート別にコード実行

  ' 実行速度計測開始
  Dim starttime As Double
  starttime = Timer

' ----------

  ' カウンタ用変数(一見見分けにくい文字同士を組み合わせない形、i と j、m と n、o(オー) と 0(ゼロ))
  Dim i As Long, k As Long

' ----------

  ' 配列に処理対象のシート名設定
  Dim sheetname() As Variant ' シート名格納用 1次元配列の変数宣言
  sheetname = Array("テスト追加シート4", "テスト追加シート5", "テスト追加シート6") ' Array 関数の要素に対象シート名代入

' ----------

  ' シート名重複判定用ブール型変数宣言
  Dim flag As Boolean
  flag = False ' 初期化

  ' LBound・UBound 関数格納用変数と代入(メモリリーク対策)
  Dim LB_sheetname As Variant, UB_sheetname As Variant
  LB_sheetname = LBound(sheetname)
  UB_sheetname = UBound(sheetname)

  ' 配列 sheetname に代入したシート名が既存のシート名と重複するかどうか判定
  ' 重複していた場合は既存の同名シートを削除、処理の最後に配列 sheetname のシート名を新規作成
  For i = LB_sheetname To UB_sheetname ' 配列 sheetname の最大要素までループ処理
    For k = 1 To Sheets.Count ' 既存のシート名取得のため、変数 k に 1 からシート数までループ処理
      If Sheets(k).Name = sheetname(i) Then ' 配列 sheetname の i 番目のシート名が、k 番目の既存のシート名と一致した場合
        flag = True ' ブール型変数に重複判定用として True を代入
      End If
    Next k

    ' 重複判定があった既存のシート名を削除
    If flag = True Then ' 重複判定用ブール型変数に True があった場合
      Application.DisplayAlerts = False ' 確認メッセージオフ
      Worksheets(sheetname(i)).Delete ' i 番目の既存のシート名を削除
      Application.DisplayAlerts = True ' 確認メッセージオン
    End If

    ' 配列 sheetname の i 番目のシート名を新規作成
    Sheets.Add(, Sheets(Sheets.Count)).Name = sheetname(i)

    flag = False ' 初期化

  Next i

' ----------

  ' 変数宣言
  Dim ws As Worksheet ' シート格納用オブジェクト変数宣言
  Dim items() As Variant ' 項目名格納用 1次元配列の変数宣言
  Dim data() As Variant ' 項目名を代入するセル範囲指定用動的配列宣言

  ' 変数宣言
  Dim selectadditems() As Variant ' Select Case で追加する項目名パターン値(Case の 0 ~ 2)を代入する 1次元配列の変数宣言
  selectadditems = Array(2, 0, 1) ' Array 関数の要素に適用させたい Select Case の項目名パターン値(Case の 0 ~ 2)を代入(要素数は配列 sheetname の要素数と必ず同じにする)

  ' LBound・UBound 関数格納用変数(メモリリーク対策)
  Dim LB_items As Variant, UB_items As Variant
  Dim UB_data_1D As Variant, UB_data_2D As Variant

  For i = LB_sheetname To UB_sheetname ' 配列 sheetname の最大要素までループ処理
  
    Set ws = ThisWorkbook.Worksheets(sheetname(i)) ' 配列 sheetname の i 番目シートをオブジェクト変数にセット
  
    Select Case selectadditems(i)

    Case 0

      ' Array 関数の要素に項目名代入
      items = Array("項目名1", "項目名2", "項目名3", "項目名4", "項目名5", "項目名6")

      ' LBound・UBound 関数格納用へ代入(メモリリーク対策)
      LB_items = LBound(items)
      UB_items = UBound(items)

      ' 配列 Item 最大要素 + 1 までを Range で範囲指定、配列として動的配列にセット
      data = GetArrFromRange.GetArrFromRange(ws.Range(ws.Cells(1, 1), ws.Cells(1, UB_items + 1)))

      ' 1次元配列のデータを 2次元配列に代入
      For k = LB_items To UB_items ' 配列 items の最大要素までループ処理
        data(1, k + 1) = items(k) ' 配列 items の k 番目のデータを、配列 data の 1 行目 k + 1 列目に格納
      Next k

      ' LBound・UBound 関数格納用変数へ代入(メモリリーク対策)
      UB_data_1D = UBound(data, 1)
      UB_data_2D = UBound(data, 2)

      ' 2次元配列 data の内容を、Range で指定したセルから Resize で範囲を変更してセルに代入
      ws.Range("A1").Resize(UB_data_1D, UB_data_2D).Value = data

    Case 1

      items = Array("項目名7", "項目名8", "項目名9", "項目名10")

      ' LBound・UBound 関数格納用へ代入(メモリリーク対策)
      LB_items = LBound(items)
      UB_items = UBound(items)

      data = GetArrFromRange.GetArrFromRange(ws.Range(ws.Cells(1, 1), ws.Cells(1, UB_items + 1)))

      For k = LB_items To UB_items
        data(1, k + 1) = items(k)
      Next k

      ' LBound・UBound 関数格納用変数へ代入(メモリリーク対策)
      UB_data_1D = UBound(data, 1)
      UB_data_2D = UBound(data, 2)

      ws.Range("A1").Resize(UB_data_1D, UB_data_2D).Value = data

    Case 2

      items = Array("項目名11", "項目名12", "項目名13", "項目名14", "項目名15")

      ' LBound・UBound 関数格納用へ代入(メモリリーク対策)
      LB_items = LBound(items)
      UB_items = UBound(items)

      data = GetArrFromRange.GetArrFromRange(ws.Range(ws.Cells(1, 1), ws.Cells(1, UB_items + 1)))

      For k = LB_items To UB_items
        data(1, k + 1) = items(k)
      Next k

      ' LBound・UBound 関数格納用変数へ代入(メモリリーク対策)
      UB_data_1D = UBound(data, 1)
      UB_data_2D = UBound(data, 2)

      ws.Range("A1").Resize(UB_data_1D, UB_data_2D).Value = data

    End Select

    ' 配列 sheetname の i 番目シート 1行目を中央揃え(水平位置)に設定
    Worksheets(sheetname(i)).Rows(1).HorizontalAlignment = xlCenter
    ' 配列 sheetname の i 番目シートすべてのセルのフォントサイズ 8 に設定
    Worksheets(sheetname(i)).Cells.Font.Size = 8
    ' 配列 sheetname の i 番目シートすべての列幅を自動調整
    Worksheets(sheetname(i)).Columns.EntireColumn.AutoFit

  Next i

' ----------

  ' 実行速度計測結果表示
  Debug.Print Format(Timer - starttime, "0.00秒")

End Sub