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

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

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

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

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