# VBA Help - Create sum formula

#### Mallesh23

##### Well-known Member
Hi Team,

Need vba help to Generate only Sum formula like'=SUM(B2+B4+B8)

Column A is Player Name and Column B is Salary.
Criteria List is in Column E.

Task is to find first Criteria Sachin if found. pick his salary. B2
Task is to find Second Criteria Dhoni if found. pick his salary. B4
Task is to find third Criteria Peterson if found. pick his salary.B8

Expected Output =Sum(b2+b4+b8)

how to achieve this task using vba. User want same formula.

Below is Table and Criteria
Book4
ABCDE
1Player NameSalaryCriteria
2Sachin13662Sachin
3Dhoni17968Dhoni
4Virat12951Peterson
5Sehwag16277
6
7
8Peterson13924
9
10Total40537=SUM(B2+B4+B8)
Sheet1
Cell Formulas
RangeFormula
B10B10=SUM(B2+B4+B8)

Thanks
mg

### Excel Facts

Create a chart in one keystroke
Select the data and press Alt+F1 to insert a default chart. You can change the default chart to any chart type

#### mehidy1437

##### Active Member
Criteria will be always in the E column & always 3 criteria?

#### VBasic2008

##### Board Regular
Create Sum Formula

• This is a fully automated solution using the `Worksheet Change` event. You don't run anything.
• If you want to run it manually then use the `getCalcSumManually` procedure.
• Although it is adjusted to your current setup, carefully read through the constants section in the procedure `calcSum` and modify if necessary.
• It will start running the first time you change a value in column `E`(`CriteriaColumn`).

Copy the following code (four procedures) into a standard module, e.g. `Module1`.

VBA Code:
``````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``````

Copy the following code (1 procedure) into a sheet module, e.g. `Sheet1`.

VBA Code:
``````Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
' This is poorly handled because it will happen even if below last cell.
If Not Intersect(Target, Columns(CriteriaColumn)) Is Nothing Then
calcSum Me
End If
End Sub``````

#### Fluff

##### MrExcel MVP, Moderator
Why not just use
Excel Formula:
``=SUM(SUMIFS(B2:B8,A2:A8,E2:E4))``

#### Mallesh23

##### Well-known Member
Hi Fluff,

Both solution provided are right, but I forgot to mention that my Criteria list are in closed workbooks Mapping sheet.

not in a single input file with criteria.

Task is to find first Criteria Sachin if found. pick his salary. B2
Task is to find Second Criteria Dhoni if found. pick his salary. B4
Task is to find third Criteria Peterson if found. pick his salary.B8

'=sum(b2+B4+B8) and so on as per criteria list , needs looping finding each cell, storing cell address in it and later sum it.

Thanks
mg

#### Peter_SSs

##### MrExcel MVP, Moderator
... but I forgot to mention ...
I am noticing comments similar to this in quite a few of your threads. I remind you of point 5.a. of the Guidelines

... make it as easy as you can for people to help you.
a. State your question clearly, including your entire need at the start.
People may tire of helping you if they continually put effort into making a suggestion only to find it was time wasted because the full information was not provided. Replies
5
Views
104
Replies
9
Views
424
Replies
3
Views
76
Replies
3
Views
88
Replies
2
Views
77