[標準モジュール module1] -----

'行列の挿入・削除をしても計算可能で、なおかつ
'途中に空白セル・空白行・空白列があっても可能

'Dim La As String
Dim La As Range
Public Lc, Lr As Integer

Sub 縦計横計()
  'La = ActiveSheet.Cells. _
  '  SpecialCells(xlCellTypeLastCell).Address()
  '
  'Range("A1 :" & La).Select
  'Lr = Selection.Rows.Count - 3
  'Lc = Selection.Columns.Count - 4
  
  If MsgBox("行列を 削除 しましたか？", 4) = vbYes Then
    ActiveWorkbook.Save   '行列削除後の最終セル認識のため再保存
  End If
  
  Set La = ActiveSheet.Cells. _
    SpecialCells(xlCellTypeLastCell)             '最終セル
  
  Lr = La.Row - 3                                'データ最終行
  Lc = La.Column - 4                             'データ最終列
  
  For i = 1 To Lc - 2                            '二列分を引算
    Cells(Lr + 2, i + 2).FormulaR1C1 = _
    "=SUM(R2C:R[-2]C)"                           '縦計
    
    If Cells(Lr + 2, i + 2) <> 0 Then
      Cells(Lr + 3, i + 2).NumberFormatLocal _
       = "0.0"
      Cells(Lr + 3, i + 2).FormulaR1C1 = _
      "=ROUND(AVERAGE(R2C:R[-3]C), 1)"           '縦平均
    Else
      Cells(Lr + 2, i + 2) = ""
    End If
  Next i
  
  For j = 1 To Lr - 1                            '一行分を引算
    Cells(j + 1, Lc + 2).FormulaR1C1 = _
    "=SUM(RC3:RC[-2])"                           '横計
    
    If Cells(j + 1, Lc + 2) <> 0 Then
      Cells(j + 1, Lc + 3).NumberFormatLocal _
       = "0.0"
      Cells(j + 1, Lc + 3).FormulaR1C1 = _
      "=ROUND(AVERAGE(RC3:RC[-3]), 1)"           '横平均
    Else
      Cells(j + 1, Lc + 2) = ""
    End If
  Next j
  
  For p = 1 To Lr - 1
    If Cells(p + 1, Lc + 2) <> "" Then
      Cells(p + 1, Lc + 4).FormulaR1C1 = _
      "=RANK(RC[-1], R2C[-1]:R" & Lr & "C[-1])"  '順位
      'この Lr に数値が入り 『" & Lr & "』 で最終行を意味する
    End If
  Next p
  Range("A1").Select
End Sub


[標準モジュール module2] -----

Sub 結果消去()
  Range(Cells(Lr + 2, 3), Cells(Lr + 3, Lc)).ClearContents
  Range(Cells(2, Lc + 2), Cells(Lr, Lc + 4)).ClearContents
End Sub

                                                              allback back top