【技術記事】最短最速で学ぶ！Excel VBA入門 – 番外編：行列計算 (後編) –

Const LeftEnumOffset As Long = 0    ' 左辺の位置のオフセット
Const ExpOffset As Long = 1         ' 演算子の位置のオフセット
Const RightEnumOffset As Long = 2   ' 右辺の位置のオフセット
Const ResultOffset As Long = 4      ' 結果の位置のオフセット

Sub 行列計算開始()
    Call Main
End Sub

Sub Main()
    ' 計算式のシートをアクティブにする
    Application.Sheets("計算式").Activate
    
    '左辺というセルを探す。
    Dim TableTopLeftRow As Integer
    Dim TableTopLeftColumn As Integer
    TableTopLeftRow = ActiveSheet.Cells.Find("左辺").Row
    TableTopLeftColumn = ActiveSheet.Cells.Find("左辺").Column
    
    '左辺のステップまで行列計算を実行する
    Dim step As Integer
    step = 1
    Do While True
        Dim leftSheetName As String
        Dim Exp As String
        Dim rightSheetName As String
        Dim resultSheetName As String
        
        ' 計算式のシートをアクティブにする
        Application.Sheets("計算式").Activate
        
        ' 左辺、演算子、右辺、計算結果の出力先のシート名の設定
        leftSheetName = Cells(TableTopLeftRow + step, TableTopLeftColumn + LeftEnumOffset)
        Exp = Cells(TableTopLeftRow + step, TableTopLeftColumn + ExpOffset)
        rightSheetName = Cells(TableTopLeftRow + step, TableTopLeftColumn + RightEnumOffset)
        resultSheetName = Cells(TableTopLeftRow + step, TableTopLeftColumn + ResultOffset)
        
        If leftSheetName = "" Or _
            Exp = "" Or _
            rightSheetName = "" Or _
            resultSheetName = "" Then
            '左辺、演算子、右辺、計算結果の出力先のシート名のいずれかが設定されていなければ、終了
            Exit Do
        End If
        
        ' 計算結果の出力先のシートを作りなおす
        RemakeSheet (resultSheetName)
        
        ' 行列計算
        Call Formula(leftSheetName, Exp, rightSheetName, resultSheetName)
        
        ' 次のステップへ
        step = step + 1
    Loop
    
    '
End Sub

Sub Formula(left As String, Exp As String, right As String, result As String)
    ' シート取得
    Dim leftSheet As Worksheet
    Dim rightSheet As Worksheet
    Dim resultSheet As Worksheet
    Set leftSheet = Sheets(left)
    Set rightSheet = Sheets(right)
    Set resultSheet = Sheets(result)
    
    ' 演算子ごとの行列計算
    Select Case (Exp)
        Case "+"
        '行列の足し算
        Call Plus(leftSheet, rightSheet, resultSheet)
        
        Case "-"
        '行列の引き算
        Call Minus(leftSheet, rightSheet, resultSheet)
        
        Case "*"
        ' 行列の掛け算
        Call Multiple(leftSheet, rightSheet, resultSheet)
        
        Case Else
        ' それ以外
        MsgBox "指定された演算子" & Exp & "は使えません"
        
    End Select
End Sub

Sub RemakeSheet(sheetName As String)
    If True = IsAlreadyExistSheet(sheetName) Then
        ' 既に作成されているシートは削除する
        Sheets(sheetName).Delete
    End If
        
    '新しいシート追加
    Dim newSheet As Worksheet
    Set newSheet = Sheets.Add
    newSheet.Name = sheetName
End Sub

Function GetMaxRow(ws As Worksheet) As Integer
    ' 一番右下のセルの行数
    GetMaxRow = ws.Cells.SpecialCells(xlLastCell).Row
End Function

Function GetMaxColumn(ws As Worksheet) As Integer
    ' 一番右下のセルの列数
    GetMaxColumn = ws.Cells.SpecialCells(xlLastCell).Column
End Function

Function IsAlreadyExistSheet(sheetName As String) As Boolean
    Dim isExistSheet As Boolean
    isExistSheet = False
    For Each Sheet In Sheets
        If sheetName = Sheet.Name Then
            ' 既にシートが作成されている
            isExistSheet = True
            Exit For
        End If
    Next Sheet
    IsAlreadyExistSheet = isExistSheet
End Function

Sub Plus(leftWs As Worksheet, rightWs As Worksheet, resultWs As Worksheet)
    '左辺と右辺の行数列数が異なれば、エラーとする
    If GetMaxRow(leftWs) <> GetMaxRow(rightWs) Or _
        GetMaxColumn(leftWs) <> GetMaxColumn(rightWs) Then
        MsgBox "左辺と右辺の行数列数が異なるためエラー"
    End If
    
    Dim i As Integer
    Dim j As Integer
    
    For i = 1 To GetMaxRow(leftWs)
        For j = 1 To GetMaxColumn(leftWs)
            resultWs.Cells(i, j) = leftWs.Cells(i, j) + rightWs.Cells(i, j)
        Next j
    Next i
End Sub


Sub Minus(leftWs As Worksheet, rightWs As Worksheet, resultWs As Worksheet)
    '左辺と右辺の行数列数が異なれば、エラーとする
    If GetMaxRow(leftWs) <> GetMaxRow(rightWs) Or _
        GetMaxColumn(leftWs) <> GetMaxColumn(rightWs) Then
        MsgBox "左辺と右辺の行数列数が異なるためエラー"
    End If
    
    Dim i As Integer
    Dim j As Integer
    
    For i = 1 To GetMaxRow(leftWs)
        For j = 1 To GetMaxColumn(leftWs)
            resultWs.Cells(i, j) = leftWs.Cells(i, j) - rightWs.Cells(i, j)
        Next j
    Next i
End Sub

Sub Multiple(leftWs As Worksheet, rightWs As Worksheet, resultWs As Worksheet)
    '左辺と右辺の行数列数が異なれば、エラーとする
    If GetMaxRow(leftWs) <> GetMaxColumn(rightWs) Or _
        GetMaxColumn(leftWs) <> GetMaxRow(rightWs) Then
        MsgBox "左辺と右辺の行数列数が異なるためエラー"
    End If
    
    Dim i As Integer
    Dim j As Integer
    
    For i = 1 To GetMaxRow(leftWs)
        For j = 1 To GetMaxColumn(leftWs)
            Dim sum As Long
            sum = 0
            For k = 1 To GetMaxColumn(leftWs)
                sum = sum + leftWs.Cells(i, k) * rightWs.Cells(k, j)
            Next k
            resultWs.Cells(i, j) = sum
        Next j
    Next i
End Sub