VBA – Quick & Impressive Recalculation of Total Sum – Video

Posted on January 15, 2014 by

Let’s imagine you are a supply chain manager of a company. You use 10 warehouses. Each warehouse has a number of pallets, it can accommodate. One day you decide to check what will happen if you simply reduce the numbers of the warehouses by 5. And you want to play with it a little.

You simply assume, that if you reduce the number of the warehouses, the number of their pallets will simply redistribute evenly amongst the other warehouses. Thus, if you have at the beginning three warehouses with 300 pallets and three with 200, if you remove one 300 pallet warehouse and one 200 pallet warehouse, you will achieve the following:

	Initial	After Removal
Warehouse 1	300	467
Warehouse 2	300	467
Warehouse 3	300
Warehouse 4	200
Warehouse 5	200	367

Seems fine, easy & understandable. And probably every 9 year old student can calculate it even without Excel.

The interesting part is that you can go a little further. With the code in the article, you can write any value in column A. And once you change a value to ZERO or you have deleted it, it will update the other values with the same logic as in the above example.

Option Explicit

Dim fd As Boolean
Dim r As Double
Dim oAd  As String
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Dn As Range
Dim c As Integer
Application.EnableEvents = False
If Not Intersect(Target, Range("A:A")) Is Nothing And Target.Count = 1 Then
    If Not Target.Address = oAd Then fd = False
    If Target = 0 Then
        If fd = True Then
            For Each Dn In Range(Cells(1, Target.Column), Cells(10, Target.Column))
                If Not Dn = 0 Then c = c + 1
            Next Dn
            For Each Dn In Range(Cells(1, Target.Column), Cells(10, Target.Column))
                If Not Dn = 0 Then Dn = Dn + r / c
            Next Dn

        End If
    End If
End If
Application.EnableEvents = True
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
 fd = False
 If Not Intersect(Target, Range("A:A")) Is Nothing And Target.Count = 1 Then
    If fd = False Then
        fd = True
        r = Target
        oAd = Target.Address
    End If
End If
End Sub

Option Explicit

Dim fd As Boolean

Dim r As Double

Dim oAd As String

Private Sub Worksheet_Change(ByVal Target As Range)

Dim Dn As Range

Dim c As Integer

Application.EnableEvents = False

If Not Intersect(Target, Range("A:A")) Is Nothing And Target.Count = 1 Then

If Not Target.Address = oAd Then fd = False

If Target = 0 Then

If fd = True Then

For Each Dn In Range(Cells(1, Target.Column), Cells(10, Target.Column))

If Not Dn = 0 Then c = c + 1

Next Dn

For Each Dn In Range(Cells(1, Target.Column), Cells(10, Target.Column))

If Not Dn = 0 Then Dn = Dn + r / c

Next Dn

End If

Application.EnableEvents = True

End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

fd = False

If Not Intersect(Target, Range("A:A")) Is Nothing And Target.Count = 1 Then

If fd = False Then

fd = True

r = Target

oAd = Target.Address

End If

End Sub

So, in order to make the code works, paste the following code in one of the sheets in VBA (not in a module). Then it works like charm for the whole “A” column. Here is a small video I have recorded in order to present it.