Author: Oscar Cronquist Article last updated on April 23, 2021 This article demonstrates two ways to calculate expenses evenly split across multiple people. The first one is a formula solution, see image above and the second one is a VBA macro solution.

## 1. How to split expenses evenly (Formula) Everything is calculated automatically, the only thing you need to enter is the expenses each person has, see Excel Table in the image above. The date and Expenses columns are not really needed for the calculations.

The formulas in cell G3:H3, and I3 calculates how much each person needs to pay and to who to split expenses evenly based on the amounts in the Excel Table.

Formula in cell G3:

=IFERROR(INDEX(\$K\$3#, SMALL(IF((\$M\$3#+SUMIF(\$G\$2:G2, \$K\$3#, \$H\$2:H2))<0, SEQUENCE(COUNT(\$M\$3#)), ""), 1)), "")

Formula in cell H3:

=IFERROR(MIN(ABS(FILTER(\$M\$3#+SUMIF(\$G\$2:G2, \$K\$3#, \$H\$2:H2)-SUMIF(\$I\$2:I2, \$K\$3#, \$H\$2:H2), \$K\$3#=G3)), ABS(FILTER(\$M\$3#+SUMIF(\$G\$2:G2, \$K\$3#, \$H\$2:H2)-SUMIF(\$I\$2:I2, \$K\$3#, \$H\$2:H2), \$K\$3#=I3))), "")

Formula in cell I3:

=IFERROR(INDEX(\$K\$3#, SMALL(IF((\$M\$3#-SUMIF(\$I\$2:I2, \$K\$3#, \$H\$2:H2))>0.1, SEQUENCE(COUNT(\$M\$3#)), ""), 1)), "")

The formulas above contain Excel 365 functions and work only in Excel 365, they use values from columns K to M, see image below. Dynamic array formula in cell K3:

=UNIQUE(Table1[Name])

Formula in cell L3:

=SUMIF(Table1[Name],K3#,Table1[Amount])

Formula in cell M3:

=L3#-SUM(Table1[Amount])/COUNTA(UNIQUE(Table1[Name]))

### Get the Excel file Split-expensesv2.xlsx

## 2. How to split expenses evenly (VBA  Macro) This workbook lets you split expenses evenly with other people. Type name, expense, and amount in the Excel table on sheet 'Expenses'. Excel returns amounts to be paid and individuals involved. This is not the macro you are looking for if you want to calculate the smallest number of transactions possible. ### How calculation sheet works The vba macro uses the values in cell range D1:E5 and calculates transactions so all sums even out.

For example, Tom pays Fred \$84.177 and his sum is 84.177 - 84.177 = 0. Hank pays Fred \$20.92, Ted \$26.87, Martin \$25.08 and his sum is 72.88 - 20.92 - 26.87 - 25.08 = 0.

Those were the necessary transactions to even out all user sums to zero. The remaining sums are now all 0, Martin's sum is -25.08 + 25.08 = 0, Ted -26.87 + 26.87 = 0 and Fred -105.098 + 84.177 + 20.92 = 0.

### How I made this workbook

There are two sheets in this workbook, 'Expenses' and 'Calculation'. Here are the formulas on 'Calculation' sheet.

Unique distinct names in column A:

=IFERROR(INDEX(Table1[Name],MATCH(0,COUNTIF(\$A\$1:A1,Table1[Name]),0)),"")

Read this post: How to extract a unique distinct list from a column

Sum values for each unique name in column B:

=IF(A2<>"",SUMIF(Table1[Name],A2,Table1[Amount]),"")

Count unique names in cell H1:

=MAX(IF(A2:A38<>"",MATCH(ROW(A2:A38),ROW(A2:A38)),""))

Sum amounts in cell G1:

=SUM(B2:B34)

VBA macro

```'Name macro
Sub SplitExp()

'Dimension variables and declare data types
Dim r As Single, d As Single, e As Single, Lrow As Single

'Disable screen refresh
Application.ScreenUpdating = False

'With ... End With statement
With Worksheets("Calculation")

'Save value in cell H1 to variable r
r = .Range("H1")

'Clear everything in columns D to E
.Columns("D:E").Clear

'Clear cell range F2:H100 in worksheet Expenses
Worksheets("Expenses").Range("F2:H100").Clear

'Save values from cell range A2:Br+1 to cell range D1:Er based on variable r
.Range("D" & 1 & ":E" & r) = .Range("A" & 2 & ":B" & r + 1).Value

'For ... Next statement
For d = 1 To r
.Range("E" & d) = (.Range("G1") / r) - .Range("E" & d)
Next d
For d = 1 To r
For e = r To 1 Step -1
Lrow = Worksheets("Expenses").Range("F" & Rows.Count).End(xlUp).Row + 1
If Round(.Range("E" & d), 2) &lt;&gt; 0 And Round(.Range("E" & e), 2) &lt;&gt; 0 Then
If Application.Min(Abs(.Range("E" & d)), Abs(.Range("E" & e))) = Abs(.Range("E" & d)) Then
Worksheets("Expenses").Range("F" & Lrow & ":H" & Lrow) = Array(.Range("D" & d), Round(Abs(.Range("E" & d)), 2), .Range("D" & e))
.Range("E" & e) = .Range("E" & e) + .Range("E" & d)
.Range("E" & d) = 0
Else
Worksheets("Expenses").Range("F" & Lrow & ":H" & Lrow) = Array(.Range("D" & d), Round(Abs(.Range("E" & e)), 2), .Range("D" & e))
.Range("E" & d) = .Range("E" & e) + .Range("E" & d)
.Range("E" & e) = 0
End If
End If
Next e
Next d
End With
Application.ScreenUpdating = True
End Sub

```

Event code, sheet 'Calculation'

```Private Sub Worksheet_Calculate()

Call SplitExp

End Sub
``` 