- Excel Version
- 2013
- The charts below represent the water level in two tanks. Each one has two series of stacked columns, and the data cells are A1 and B1. There is a link to the workbook on this post.
- The idea is to transfer water from one tank to another, so just enter a percent level variation for one tank, like 20 or -30, and the charts will gradually change.
- The animation speed can be adjusted in the code.
- This is part of a larger project, so the code may look a bit weird.
DoubleAnim.xlsm
VBA Code:
Public Type Dbasin
ba(1 To 3) As Integer '1=percent level 2=starting level 3=final
End Type
Dim unit, basin(1 To 2) As Dbasin
Sub Main()
Sheets("tanks").Activate
unit = Calc_Unit([d8])
basin(1).ba(1) = [a1] * 100
basin(2).ba(1) = [b1] * 100
If Len([f28]) And Len([p28]) Then
MsgBox "Choose only one tank.", vbCritical
Exit Sub
End If
If Len([f28]) = 0 And Len([p28]) = 0 Then
MsgBox "Choose level variation for a tank", vbExclamation
Exit Sub
End If
If Len([f28]) Then [p28] = -[f28]
If Len([p28]) Then [f28] = -[p28]
AnimateTwo [f28], [p28]
End Sub
Sub AnimateTwo(d1%, d2%)
Dim j%, i%, delta%(1 To 2), mstep%(1 To 2), finish%
finish = 0
delta(1) = d1
delta(2) = d2
For i = 1 To 2
basin(i).ba(2) = basin(i).ba(1)
basin(i).ba(3) = basin(i).ba(1) + delta(i)
mstep(i) = 1
If basin(i).ba(3) > 100 Then basin(i).ba(3) = 100
If basin(i).ba(3) < 0 Then basin(i).ba(3) = 0
If basin(i).ba(3) - basin(i).ba(1) < 0 Then mstep(i) = -1
Next
If d1 <> 0 Then finish = Abs(d1)
If d2 <> 0 Then finish = Abs(d2)
For i = 1 To finish
For j = 1 To 2
If delta(j) <> 0 Then
ActiveSheet.Cells(1, j) = (basin(j).ba(1) + mstep(j)) / 100
DoEvents
basin(j).ba(1) = basin(j).ba(1) + mstep(j)
If basin(j).ba(1) > 100 Or basin(j).ba(1) < 0 Then Exit Sub
End If
Next
Delay unit * 4 ' adjust speed here
DoEvents
Next
End Sub
Sub Delay(nb#)
Dim c&, m#
For c = 1 To nb
m = (c / (c + 1) * 0.4) + 5.9
Next
End Sub
Function Calc_Unit#(sv%)
If sv < 51 Then
Calc_Unit = 4982 * Exp(-0.04 * sv)
Else
Calc_Unit = (-0.169 * (sv ^ 2)) + 13.6 * sv + 393
End If
Calc_Unit = Round(Calc_Unit * 1000)
End Function
