• If you would like to post, please check out the MrExcel Message Board FAQ and click here to register.
    If you forgot your password, you can reset your password.
  • Excel articles and downloadable files provided in the articles have not been reviewed by MrExcel Publishing. Please apply the provided methods / codes and open the files at your own risk.
    If you have any questions regarding an article, please use the Article Discussion section.
Worf

Double chart animation with VBA

  • 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

twotanks.JPG


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
Excel Version
2013
  • Like
Reactions: Excel Arsivi
Author
Worf
Views
304
First release
Last update
Rating
5.00 star(s) 1 ratings

More Excel articles from Worf

Some videos you may like

This Week's Hot Topics

Top