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:

Want to know more about this array formula?
Read this post: How to extract a unique distinct list from a column

Sum values for each unique name in column B:

Count unique names in cell H1:

Sum amounts in cell G1:

VBA macro

Sub SplitExp()
Dim r As Single, d As Single, e As Single, Lrow As Single
Application.ScreenUpdating = False
With Worksheets("Calculation")
r = .Range("H1")
.Columns("D:E").Clear
Worksheets("Expenses").Range("F2:H100").Clear
.Range("D" & 1 & ":E" & r) = .Range("A" & 2 & ":B" & r + 1).Value
For d = 1 To r
.Range("E" & d) = (.Range("G1") / r) - .Range("E" & d)
Next d
.Columns("D:E").Sort key1:=.Range("E1"), order1:=xlDescending, Header:=xlNo
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) <> 0 And Round(.Range("E" & e), 2) <> 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

If you want to learn more about array formulas join Advanced excel course.

Download excel *.xlsx file

Split expenses in excel.xlsm

---

Weekly Blog EMAIL

Email

Welcome! I am Oscar and here to help you out.

Feel free to comment and ask Excel questions.

Make sure you subscribe to my newsletter so you don't miss new blog articles.

Related articles

---