Option Explicit
Public Const CriteriaColumn As String = "E" ' because of automation
Sub getCalcSumManually()
Const wsName As String = "Sheet1"
Dim wb As Workbook
Set wb = ThisWorkbook ' The workbook containing this code.
Dim ws As Worksheet
Set ws = wb.Worksheets(wsName)
calcSum ws
End Sub
' If you need the result (not the formula) then outcomment the three lines
' containing 'FResult' and uncomment the three lines containing 'Result'.
Sub calcSum(Sheet As Worksheet)
Const FirstRow As Long = 2 ' First Row Number
Const cLR As Variant = "A" ' Last Row Column Index
Const cLRCriteria As String = "Total" ' Last Row Column Criteria
Const cLRRowOffset As Long = -2 ' Last Row Column Row Offset
Const TargetCol As Variant = "D" ' Target Column Index
Dim Cols As Variant ' Columns Array
' 'VBA' to ensure 0-based.
Cols = VBA.Array("A", "B", CriteriaColumn)
' Write values from column ranges to arrays.
' Find the cell two rows above ('-2','cLRColOffset') the last cell
' containing "Total" ('cLRCriteria') in column "A" ('cLR').
Dim LastCell As Range
getLastCellInColumn LastCell, Sheet, cLR, cLRRowOffset, , cLRCriteria
' Define Last Row Column Range
Dim rng As Range
Set rng = Sheet.Range(Sheet.Cells(FirstRow, Cols(0)), LastCell)
' Define Jagged Columns Array (the same size as Columns Array).
Dim Data As Variant
ReDim Data(0 To 2)
' Write values from Column Ranges to arrays of Column Array.
Dim j As Long
' Backwards to exit as soon as possible if no data in 'E' column.
For j = 2 To 0 Step -1
getColumnRange Data(j), rng.Offset(, Sheet.Columns(Cols(j)) _
.Column - rng.Column)
If IsEmpty(Data(j)) Then GoTo ProcExit
Next j
' Calculate result.
' Additional variables for the 'For Next' loop.
Dim CurrIndex As Variant
'Dim Result As Double
Dim FResult As String
Dim i As Long
' Calculate result.
For i = 1 To UBound(Data(2)) ' or 0 or 1
If Not IsEmpty(Data(2)(i, 1)) Then
' Try to find the current name from 'E' column in 'A' column.
CurrIndex = Application.Match(Data(2)(i, 1), Data(0), 0)
If Not IsError(CurrIndex) Then
'Result = Result + Data(1)(CurrIndex, 1)
FResult = FResult & "+" & Cols(1) & CStr(CurrIndex + FirstRow - 1)
End If
End If
Next i
' Write result.
' Define Resulting Cell.
Dim cLRColOffset As Long ' Last Row Column Column Offset
cLRColOffset = Sheet.Columns(TargetCol).Column - Sheet.Columns(cLR).Column
getLastCellInColumn LastCell, Sheet, cLR, , cLRColOffset, cLRCriteria
' Write Result to Resulting Cell.
'LastCell.Value = Result
LastCell.Formula = "=SUM(" & Right(FResult, Len(FResult) - 1) & ")"
' You actually don't need 'SUM' and the parentheses at all
' to make the formula work. Think about it.
ProcExit:
End Sub
' Writes the values of a column range to a 2D one-based array.
Sub getColumnRange(ByRef Data As Variant, _
ColumnRange As Range)
Data = Empty
If ColumnRange Is Nothing Then
GoTo ProcExit
End If
If ColumnRange.Rows.Count > 1 Then
' Column Range contains multiple cells.
Data = ColumnRange.Value
Else
' Column Range contains one cell.
ReDim Data(1 To 1, 1 To 1)
Data(1, 1) = ColumnRange.Value
End If
ProcExit:
End Sub
' Gets the last cell in a column containing a specified criteria
' with an applied offset.
Sub getLastCellInColumn(ByRef LastCell As Range, _
Optional Sheet As Worksheet = Nothing, _
Optional ByVal ColumnIndex As Variant = 1, _
Optional ByVal RowOffset As Long = 0, _
Optional ByVal ColumnOffset As Long = 0, _
Optional ByVal Criteria As Variant = "*")
If Sheet Is Nothing Then
Set Sheet = ActiveSheet
End If
If Criteria = "*" Then
Set LastCell = Sheet.Columns(ColumnIndex) _
.Find(What:="*", _
LookIn:=xlFormulas, _
SearchDirection:=xlPrevious) _
.Offset(RowOffset, ColumnOffset)
Else
Set LastCell = Sheet.Columns(ColumnIndex) _
.Find(What:=Criteria, _
LookIn:=xlFormulas, _
LookAt:=xlWhole, _
SearchDirection:=xlPrevious, _
MatchCase:=True) _
.Offset(RowOffset, ColumnOffset)
End If
End Sub
