Excel VBA Functionプロシージャを使いこなす。スキルを飛躍的に向上させる効率的な事務処理テクニック！

Excel VBA Functionプロシージャを使いこなす。スキルを飛躍的に向上させる効率的な事務処理テクニック！

’
’
Function SumArray(ByVal rng As Range) As Double
    ' 宣言：ループカウンタ用の変数
    Dim i As Long
    
    ' 宣言：合計値を格納するための変数
    Dim sum As Double
    
    ' ループ：rng内のすべてのセルに対して処理を実行
    For i = 1 To rng.Cells.Count
        ' 演算：現在のセルの値をsum変数に加算
        sum = sum + rng.Cells(i).Value
    ' 次のセルへ移動
    Next i
    
    ' 関数の戻り値：sum変数の値をSumArray関数の結果として返す
    SumArray = sum
End Function
’
’

Excel VBA Functionプロシージャを使いこなす。最大値と最小値を取得する自作関数を作成する。

’
’
Function GetMinMax(rng As Range, Optional ByVal getMin As Boolean = True) As Double
    If getMin Then　’選択範囲からTRUEで最小値を取得
        GetMinMax = Application.WorksheetFunction.Min(rng)
    Else　’選択範囲からFalseで最大値を取得
        GetMinMax = Application.WorksheetFunction.Max(rng)
    End If
End Function
’
’

Excel VBA Functionプロシージャを使いこなす。表範囲を範囲を取得する（開始列・終了列・開始行・終了行）

Option Explicit

'
'
Sub GetTableInfo()
    ' ワークシートを設定
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Worksheets("Sheet1")
    
    ' 開始セルを設定
    Dim startCell As Range
    Set startCell = ws.Range("B2")
    
    ' 関数を呼び出して、表の情報を取得
    Dim tableInfo As Variant
    tableInfo = GetTableInfoFromWs(ws, startCell)
    
    ' 取得した表の情報をメッセージボックスに表示
    MsgBox "表の範囲: " & tableInfo(0) & vbCrLf & _
           "開始行: " & tableInfo(1) & vbCrLf & _
           "開始列: " & tableInfo(2) & vbCrLf & _
           "最終行: " & tableInfo(3) & vbCrLf & _
           "最終列: " & tableInfo(4), vbInformation, "結果"
End Sub

Function GetTableInfoFromWs(ws As Worksheet, startCell As Range) As Variant
    ' 開始行と開始列を取得
    Dim startRow As Long
    Dim startCol As Long
    startRow = startCell.Row
    startCol = startCell.Column
    
    ' 最終行と最終列を取得
    Dim lastRow As Long
    Dim lastCol As Long
    lastRow = startCell.End(xlDown).Row
    lastCol = startCell.End(xlToRight).Column
    
    ' 表の範囲を取得
    Dim tableRange As Range
    Set tableRange = ws.Range(startCell, ws.Cells(lastRow, lastCol))
    
    ' 表の情報を配列に格納
    Dim result(0 To 4) As Variant
    result(0) = tableRange.Address
    result(1) = startRow
    result(2) = startCol
    result(3) = lastRow
    result(4) = lastCol
    
    ' 配列を戻り値として返す
    GetTableInfoFromWs = result
End Function
'
'

Excel VBA Functionプロシージャを使いこなす。繰り返し集計表（マトリックス表）を作成する。

’
’
Option Explicit

Sub ExecuteCreateMatrixTable01()
    Dim ws As Worksheet
    Dim wsOutput As Worksheet

    ' ワークシートを設定
    Set ws = ThisWorkbook.Worksheets("DATA1")
    Set wsOutput = ThisWorkbook.Worksheets("表作成")
    
    ' CreateMatrixTable関数を実行
    CreateMatrixTable ws, wsOutput
End Sub


Sub ExecuteCreateMatrixTable02()
    Dim ws As Worksheet
    Dim wsOutput As Worksheet

    ' ワークシートを設定
    Set ws = ThisWorkbook.Worksheets("DATA2")
    Set wsOutput = ThisWorkbook.Worksheets("表作成")
    
    ' CreateMatrixTable関数を実行
    CreateMatrixTable ws, wsOutput
End Sub

Sub ExecuteCreateMatrixTable03()
    Dim ws As Worksheet
    Dim wsOutput As Worksheet

    ' ワークシートを設定
    Set ws = ThisWorkbook.Worksheets("DATA3")
    Set wsOutput = ThisWorkbook.Worksheets("表作成")
    
    ' CreateMatrixTable関数を実行
    CreateMatrixTable ws, wsOutput
End Sub


Function CreateMatrixTable(ws As Worksheet, wsOutput As Worksheet)
    Dim rng As Range
    Dim dict As Object
    Dim lastRow As Long, lastCol As Long
    
    
    ' 最後の行と列を取得
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).row
    lastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
    Set rng = ws.Range(ws.Cells(2, 1), ws.Cells(lastRow, lastCol))
    
    ' マトリックスデータを作成
    Set dict = CreateMatrixData(rng)
    ' マトリックス表をクリアします。
    wsOutput.Cells.Clear
    ' マトリックス表を出力
    OutputMatrixTable wsOutput, dict
    ' マトリックス表をアクティブにする
    wsOutput.Activate
    
End Function

Function CreateMatrixData(rng As Range) As Object
    Dim dict As Object
    Dim cell As Range
    Dim key As String

    ' スクリプトディクショナリオブジェクトを作成
    Set dict = CreateObject("Scripting.Dictionary")

    ' セルを走査してマトリックスデータを作成
    For Each cell In rng.Cells
        If cell.Column = 1 Then
            key = cell.Value
        ElseIf cell.Column = 2 Then
            key = key & "_" & cell.Value
            If Not dict.Exists(key) Then
                dict.Add key, 0
            End If
        ElseIf cell.Column = 3 Then
            dict(key) = dict(key) + cell.Value
        End If
    Next cell

    ' マトリックスデータオブジェクトを返す
    Set CreateMatrixData = dict
End Function

Sub OutputMatrixTable(ws As Worksheet, dict As Object)
    Dim key As Variant
    Dim keys As Variant
    Dim k As Variant
    Dim row As Long
    Dim col As Long
    Dim rowIndex As Object, columnIndex As Object
    Dim r As Long, c As Long
    Dim rngTable As Range

    ' 行と列のインデックスディクショナリを作成
    Set rowIndex = CreateObject("Scripting.Dictionary")
    Set columnIndex = CreateObject("Scripting.Dictionary")

    row = 2
    col = 2

    ' 一意の行と列のインデックスを設定
    For Each key In dict.keys
        keys = Split(key, "_")

        If Not rowIndex.Exists(keys(0)) Then
            rowIndex.Add keys(0), row
            ws.Cells(row, 1).Value = keys(0)
            row = row + 1
        End If

        If Not columnIndex.Exists(keys(1)) Then
            columnIndex.Add keys(1), col
            ws.Cells(1, col).Value = keys(1)
            col = col + 1
        End If
    Next key
    
        ' マトリックス表に値を入力
    For Each key In dict.keys
        keys = Split(key, "_")
        r = rowIndex(keys(0))
        c = columnIndex(keys(1))
        ws.Cells(r, c).Value = dict(key)
    Next key

    ' 表の範囲を特定
    Set rngTable = ws.Range(ws.Cells(1, 1), ws.Cells(row - 1, col - 1))

    ' 罫線を適用し、列幅を自動調整
    With rngTable
        .Borders.LineStyle = xlContinuous
        .EntireColumn.AutoFit
    End With
End Sub
’
’