Overview
This is a major update to my original Transaction Splitter for Excel (VBA) where I rewrote most of the code to make it more efficient and added the saved capabilities.
Same caveats as the original one.
Installation
I would recommend installing this only if you have some familiarity with VBA. The code works, but it’s VBA, so you should be able to know how to install and how to run. The code is here:
VBA Code
Sub SplitTransactionWithCustomAmounts()
Dim ws As Worksheet
Dim selectedRow As Range
Dim headerRow As Range
Dim descCol As Long
Dim amtCol As Long
Dim catCol As Long
Dim noteCol As Long
Dim dateCol As Long
Dim numRowsToAdd As Long
Dim i As Long
Dim splitAmts() As Variant
Dim splitCat() As String
Dim splitDesc() As String
Dim totalSplitAmt As Double
' Set references to the active worksheet, selected row, and header row
Set ws = ActiveSheet
Set selectedRow = ws.Cells.Find(What:="*", SearchDirection:=xlPrevious)
Set headerRow = selectedRow.End(xlUp)
amtCol = 4
dateCol = 1
descCol = 2
catCol = 3
noteCol = 21
' Get the original transaction information from the selected row
Dim origDesc As String
Dim origAmt As Double
Dim origDate As String
origDesc = Cells(ActiveCell.Row, descCol)
origAmt = Cells(ActiveCell.Row, amtCol)
origDate = Cells(ActiveCell.Row, dateCol)
origrow = ActiveCell.Row
' Prompt user to confirm split and verify $0 split
Dim confirmMsg As String
If origAmt = 0 Then
confirmMsg = "Amount of transaction on selected row is $0. Do you still want to continue?"
If MsgBox(confirmMsg, vbYesNo, "Continue?") <> vbYes Then
Exit Sub
End If
End If
confirmMsg = "Please confirm the following transaction details:" & vbCrLf _
& "Date: " & origDate & vbCrLf _
& "Description: " & origDesc & vbCrLf _
& "Amount: " & origAmt & vbCrLf & vbCrLf _
& "Do you want to split this transaction?"
If MsgBox(confirmMsg, vbYesNo, "Confirm Split") <> vbYes Then
Exit Sub
End If
Dim fullinput As String
Dim splitinput As Variant
Dim useSavedSplit As VbMsgBoxResult
useSavedSplit = MsgBox("Do you want to use a saved split?", vbYesNo + vbQuestion, "Use Saved Split")
If useSavedSplit = vbYes Then
Dim uniqueSplitValues As Variant
uniqueSplitValues = GetUniqueValues()
' User wants to use a saved split
Dim splitName As String
splitName = InputBox("Enter the name of the saved split:" & vbNewLine & Join(uniqueSplitValues, vbNewLine), "Saved Split Names")
If splitName = "" Then Exit Sub ' Exit the sub if the user cancels the input box
Dim splitInfoSheet As Worksheet
Dim splitInfoRow As Range
Set splitInfoSheet = ThisWorkbook.Sheets("SavedSplits")
Dim firstSplitRow As Range
Set firstSplitRow = splitInfoSheet.Columns("A").Find(What:=splitName, LookIn:=xlValues, LookAt:=xlWhole)
If Not firstSplitRow Is Nothing Then
Dim lastSplitRow As Range
Set lastSplitRow = firstSplitRow
Do While lastSplitRow.Cells(1, 1) = splitName
Set lastSplitRow = lastSplitRow.Offset(1, 0)
Loop
Set lastSplitRow = lastSplitRow.Offset(-1, 0)
numRowsToAdd = lastSplitRow.Row - firstSplitRow.Row + 1
ReDim splitAmts(1 To numRowsToAdd)
ReDim splitCat(1 To numRowsToAdd)
ReDim splitDesc(1 To numRowsToAdd)
For i = 1 To numRowsToAdd
splitAmts(i) = firstSplitRow.Cells(i, 3)
splitCat(i) = firstSplitRow.Cells(i, 2)
splitDesc(i) = firstSplitRow.Cells(i, 4)
Next i
For i = 1 To numRowsToAdd
fullinput = Application.InputBox("Enter the amount, category, and description for split " _
& vbNewLine & i & " of " & numRowsToAdd & " (each separated by a comma):" & vbNewLine & _
vbNewLine & "Current values: Amount: " & Format(splitAmts(i), "$#,##0.00") & ", Category: " & _
splitCat(i) & ", Description: " & splitDesc(i) & vbNewLine & _
"You may leave a field blank to keep its current value.")
If fullinput <> "" Then
' User entered new values, update the corresponding elements in the split arrays
splitinput = Split(fullinput, ",")
If UBound(splitinput) >= 0 And IsNumeric(splitinput(0)) Then _
splitAmts(i) = CDbl(splitinput(0))
If UBound(splitinput) >= 1 Then _
splitCat(i) = Trim(splitinput(1))
If UBound(splitinput) >= 2 Then _
splitDesc(i) = Trim(splitinput(2))
End If
' Last chance to exit.
totalSplitAmt = totalSplitAmt + splitAmts(i)
Next i
If Round(totalSplitAmt, 4) <> Round(origAmt, 4) Then
MsgBox "The total amount of the splits does not equal the original amount. Please adjust the split amounts." & vbNewLine & _
"Original Amount:" & origAmt & vbNewLine & _
"Total Amount" & totalSplitAmt & vbExclamation
Exit Sub
End If
confirmMsg = "Please confirm the following splits:" & vbNewLine & vbNewLine
For i = 1 To numRowsToAdd
confirmMsg = confirmMsg & " Split " & i & ": Amount:" & Format(splitAmts(i), "$#,##0.00") & _
" Category: " & splitCat(i) & " Desc: " & splitDesc(i) & vbNewLine
Next i
confirmMsg = confirmMsg & vbNewLine & "Total: " & Format(totalSplitAmt, "$#,##0.00") & vbNewLine & vbNewLine & "Is this correct?"
' Ask user to confirm the splits
Dim confirmResult As VbMsgBoxResult
' confirmResult = MsgBox(confirmMsg, vbYesNo + vbQuestion, "Confirm Splits")
confirmResult = MsgBox(confirmMsg, vbYesNo + vbQuestion + vbDefaultButton2, "Confirm Splits")
If confirmResult = vbYes Then
InsertRowsForSplits numRowsToAdd, amtCol, catCol, descCol, noteCol, splitAmts, splitCat, splitDesc
' Show success message to user
MsgBox "The transaction has been split successfully.", vbInformation, "Split Transaction"
Exit Sub
Else
' Show message to user that the split was cancelled
MsgBox "The split transaction was cancelled.", vbExclamation, "Split Transaction"
Exit Sub
End If
Else
' Split information not found, display an error message and exit the sub
MsgBox "Saved split not found. Please check the name and try again.", vbExclamation, "Split Not Found"
Exit Sub
End If
Else
' User wants to enter the split information manually
numRowsToAdd = Application.InputBox("Enter the number of splits needed: (include the original row in the split) ", "Number of Splits")
End If
If numRowsToAdd < 2 Then Exit Sub ' Exit the sub if the user inputs 0 or a negative number
ReDim splitAmts(1 To numRowsToAdd)
ReDim splitCat(1 To numRowsToAdd)
ReDim splitDesc(1 To numRowsToAdd)
For i = 1 To numRowsToAdd
fullinput = Application.InputBox("Enter the amount, category, and description for split " _
& vbNewLine & i & " of " & numRowsToAdd & " (each separated by a comma):" & vbNewLine & _
vbNewLine & "You may leave a field blank, but you must still put in a comma." _
& vbNewLine & "Total split so far: $" & totalSplitAmt & ". Original Amount: $" & origAmt & " Amount Left to Split: $" & origAmt - totalSplitAmt)
splitinput = Split(fullinput, ",")
splitAmts(i) = splitinput(0)
splitCat(i) = splitinput(1)
splitDesc(i) = splitinput(2)
If Not IsNumeric(splitAmts(i)) Or splitAmts(i) = 0 Then
MsgBox "Invalid input for split amount. Please enter a valid number.", vbExclamation
Exit Sub
End If
totalSplitAmt = totalSplitAmt + splitAmts(i)
Next i
If Round(totalSplitAmt, 4) <> Round(origAmt, 4) Then
MsgBox "The total amount of the splits does not equal the original amount. Please adjust the split amounts.", vbExclamation
Exit Sub
End If
' Last chance to exit.
confirmMsg = "Please confirm the following splits:" & vbNewLine & vbNewLine
For i = 1 To numRowsToAdd
confirmMsg = confirmMsg & " Split " & i & ": Amount:" & Format(splitAmts(i), "$#,##0.00") & _
" Category: " & splitCat(i) & " Desc: " & splitDesc(i) & vbNewLine
Next i
confirmMsg = confirmMsg & vbNewLine & "Total: " & Format(totalSplitAmt, "$#,##0.00") & vbNewLine & vbNewLine & "Is this correct?"
' Ask user to confirm the splits
' Dim confirmResult As VbMsgBoxResult
' confirmResult = MsgBox(confirmMsg, vbYesNo + vbQuestion, "Confirm Splits")
confirmResult = MsgBox(confirmMsg, vbYesNo + vbQuestion + vbDefaultButton2, "Confirm Splits")
If confirmResult = vbYes Then
InsertRowsForSplits numRowsToAdd, amtCol, catCol, descCol, noteCol, splitAmts, splitCat, splitDesc
' Show success message to user
MsgBox "The transaction has been split successfully.", vbInformation, "Split Transaction"
Else
' Show message to user that the split was cancelled
MsgBox "The split transaction was cancelled.", vbExclamation, "Split Transaction"
Exit Sub
End If
End Sub
Function GetUniqueValues() As Variant
'Create a reference to the SavedSplit worksheet
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("SavedSplits")
'Create a dictionary to store the unique values
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")
'Find the last row in Column A of the SavedSplit worksheet
Dim lastRow As Long
lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
'Loop through the values in Column A of the SavedSplit worksheet and add them to the dictionary
Dim i As Long
For i = 2 To lastRow
dict(ws.Cells(i, "A").Value) = 1
Next i
'Return the unique values as an array
GetUniqueValues = dict.Keys
End Function
Private Sub InsertRowsForSplits(ByVal numRowsToAdd As Long, ByVal amtCol As Long, ByVal catCol As Long, _
ByVal descCol As Long, ByVal noteCol As Long, ByRef splitAmts() As Variant, _
ByRef splitCat() As String, ByRef splitDesc() As String)
Dim i As Long
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
' Update amount, category, and description for original row
Cells(ActiveCell.Row, amtCol).Value = splitAmts(1)
Cells(ActiveCell.Row, catCol).Value = splitCat(1)
Cells(ActiveCell.Row, descCol).Value = splitDesc(1)
Cells(ActiveCell.Row, noteCol).Value = FormatCurrency(Cells(ActiveCell.Row, amtCol).Value) & " of " & _
FormatCurrency(origAmt) & " split from " & origDesc & " on " & origDate
' Insert new rows for additional splits (skip the first row as it's already updated)
For i = 2 To numRowsToAdd
' Insert a new row
Rows(ActiveCell.Row + i - 1).Insert Shift:=xlDown
' Copy data from original row
Rows(ActiveCell.Row).Copy Rows(ActiveCell.Row + i - 1)
' Update amount for split
Cells(ActiveCell.Row + i - 1, amtCol).Value = splitAmts(i)
' Update category for split
Cells(ActiveCell.Row + i - 1, catCol).Value = splitCat(i)
' Update description for split
Cells(ActiveCell.Row + i - 1, descCol).Value = splitDesc(i)
' Update note for split
Cells(ActiveCell.Row + i - 1, noteCol).Value = FormatCurrency(splitAmts(i)) & " of " & _
FormatCurrency(origAmt) & " split from " & origDesc & " on " & origDate
Next i
' Reset the selection to the first cell in the original row
Cells(ActiveCell.Row, amtCol).Select
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
The code itself is made up of several subs and functions to make it easier to maintain and run.
Setup
First thing you have to do is go to the code and make sure the column numbers for the Transaction table are correct. In my code it’s:
amtCol = 4
dateCol = 1
descCol = 2
catCol = 3
noteCol = 21
Then, if you will be using the saved splits feature, you need to add a sheet called SavedSplits with the following columns in this order:
splitName,Category,Amount,Description
Usage
Usage is as before, with the addition of Saved Splits. If you run a saved split and the details are the same, you can just press enter. Otherwise, you can fill in the information for that split.
Permissions
Is it ok for others to copy, use, and modify your workflow?
Yes
Notes
I tested it, but you never know how VBA acts, so use with caution. As before, there is a final confirmation that you can always break in case things look wonky.
FAQ
Optionally, add common questions and answers…
