• If you would like to post, please check out the MrExcel Message Board FAQ and register here.
    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

Excel Version
  1. 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

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
Author
Worf
Views
1,284
First release
Last update
Rating
5.00 star(s) 1 ratings

More Excel articles from Worf

This Week's Hot Topics

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top