Creating Animated Chart GIFs with Excel VBA

Do you have some complex charts and slides you, or your client, want posted on Twitter, LinkedIn, Medium, FB or almost any web page?

Here’s output from this project. Tracking Covid and Temperature in Massachusetts.

Is one chart not enough to tell your story? Are you limited by what you can post on Twitter, say? (where you can’t use Javascript libraries).

I want a one-stop solution for robust internet API calls, data extraction, transformations, charting, SFTP uploads, etc. So I used Excel VBA and command-line apps to create animated GIFs. The following is a template that can be quickly modified to create chart PNGs, JPGS, or animated GIFs. I can even schedule it to run automatically through a cron job on my PC.

You can Download zip file. This VBA solution is meant to get someone who programs up and running.

Another benefit of Excel, over Python, is that it is easy to give to anyone, and they can run it, without knowing a thing about programming languages, libraries IDEs, and so forth. If they have Excel, they’re good to go!

Here’s a sample of the animated GIF output

The VBA code below will pick up configuration data from my master sheet. Although I’m not using ODBC databases here, I’ve left in the possibility to add them later. Yes, this is crude, but all the end-user sees are the charts!

Configs for working with many kinds of data and parameters.

Data

For the Covid data I download the latest history file from covidtracking.com (Apologies for my lazy and unorthodox programming style). Also, I only expect the reader to skim over the code. Again, I just want to get things done so some of the code was created by the macro-recorder which I copy-and-pasted in procedures.

Sub DOCAA_s01_Download_Data_CSV_Covid()Dim ws As Worksheet
Dim sURL, sUseSheet, sThisSheet As String
sThisSheet = ActiveSheet.Name ' The master sheet we create charts on fromsUseDataSheet = "Data_COVID"
sURL = "https://covidtracking.com/data/download/massachusetts-history.csv"
' Delete old data sheet if exists
For Each ws In Worksheets
If ws.Name = sUseSheet Then
Application.DisplayAlerts = False
Sheets(sUseDataSheet).Delete
Application.DisplayAlerts = True
End If
Next
' Create sheet ' After:=Sheets(Sheets.Count)
Sheets.Add(Before:=Sheets(1)).Name = sUseSheet
' Download CSV and add to sheet
Set ws = ActiveWorkbook.Sheets(sUseDataSheet)
With ws.QueryTables.Add(Connection:="TEXT;" & sURL, Destination:=ws.Range("A1"))
.TextFileParseType = xlDelimited
.TextFileCommaDelimiter = True
.Refresh
End With
Cells.Select
ActiveWorkbook.Worksheets(sUseDataSheet).Sort.SortFields.Clear
ActiveWorkbook.Worksheets(sUseDataSheet).Sort.SortFields.Add2 Key:=Range( _
"A2:A248"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
With ActiveWorkbook.Worksheets(sUseDataSheet).Sort
.SetRange Range("A1:AQ1000")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Range("A1").Select
' Delete the attached "Excel memorized" querytable if there is one
On Error GoTo nothingtodelete
Sheets(sUseSheet).QueryTables(1).SaveData = False
Sheets(sUseSheet).QueryTables.item(1).Delete
nothingtodelete:
' return to calling master sheet
Sheets(sThisSheet).Select
End Sub

For the weather data, we’ll need to use this open-source VBA-tools/VBA_JSON library. It’s probably overkill. Nonetheless, whatever works out of the box I use. There is VBA code for just about anything,a quick internet search away.

Sub DOCAA_s03_Download_Data_JSON_Weather()
Dim sAPI, sThisSheet As String
Dim response
Dim jsonObject As Object, item As Object
Dim ws As Worksheet
sThisSheet = ActiveSheet.Name ' current master sheet' ***
' PREPARE SHEET
' ***
sUseDataSheet = "Data_Weather"
' Delete old one if exists
For Each ws In Worksheets
If ws.Name = sUseSheet Then
Application.DisplayAlerts = False
Sheets(sUseDataSheet).Delete
Application.DisplayAlerts = True
End If
Next
' Create sheet ' After:=Sheets(Sheets.Count)
Sheets.Add(Before:=Sheets(1)).Name = sUseDataSheet
Set ws = ActiveSheet
ws.Cells(1, 1) = "date"
ws.Cells(1, 2) = "AvgAirTemp"
ws.Cells(1, 3) = "MinAirTemp"
ws.Cells(1, 4) = "MaxAirTemp"
ws.Cells(1, 5) = "PrecipitationMM"
ws.Cells(1, 6) = "SnowDepthMM"
ws.Cells(1, 7) = "AvgWindDirection"
ws.Cells(1, 8) = "AvgWindSpeed"
ws.Cells(1, 9) = "PeakWindGust"
ws.Cells(1, 10) = "AvgSeaLevelAirPressure"
ws.Cells(1, 11) = "SunshineTotalMinutes"
' ***
' NOW GET DATA
' ***
' Explains API call technique below.
' https://wellsr.com/vba/2019/excel/vba-http-get-requests-api-serverxmlhttp60/
Dim request As MSXML2.ServerXMLHTTP60Dim apiURL As String, requestString As String, header_name As String, sEndDatesEndDate = Format(Now, "YYYY-MM-DD")apiURL = "https://api.meteostat.net/v2/stations/daily?station=72509&start=2020-01-01&end=" & sEndDate
header_name = "x-api-key"
sx_api_key = "8Rwh...get_yer_own_key_Medium_reader:)"
Set request = New ServerXMLHTTP60
request.Open "GET", apiURL, False
request.setRequestHeader header_name, sx_api_keyrequest.send
response = request.responseText
If response <> "" Then
Set jsonObject = jsonConverter.ParseJson(response)

Dim i
i = 2
For Each item In jsonObject("data")
ws.Cells(i, 1) = item("date")
ws.Cells(i, 2) = item("tavg")
ws.Cells(i, 3) = item("tmin")
ws.Cells(i, 4) = item("tmax")
ws.Cells(i, 5) = item("prcp")
'ws.Cells(i, 6) = Item("address")("suite") 'if nested
ws.Cells(i, 6) = item("snow")
ws.Cells(i, 7) = item("wdir")
ws.Cells(i, 8) = item("wspd")
ws.Cells(i, 9) = item("wpgt")
ws.Cells(i, 10) = item("pres")
ws.Cells(i, 11) = item("tsun")
i = i + 1
Next
Else
Debug.Print "Json string returned empty"
End If

Sheets(sThisSheet).Select
End Sub

We now have two sheets of data, Covid and Weather.

ORGANIZE

I’ll spare you the code. Next, I copy the Covid data over to the master sheet. I then create VLOOKUPs on the dates to fill in the temperature data. I then have some quick-and-dirty code that deletes outliers.

CHART

I then create three charts, each one pulling from a different date range. For brevity, here is the last which gets the last 30 days.

Range("A1").Select ' make sure chart not activated
sChartName = "CovidChart3"
sTitle = "Track MA Covid with Weather (Last 30 Days)"
vTrendLineVal = 7
' We want to get number of rows of data. Will use own helper function
vEndRow = ws.Cells.SpecialCells(xlCellTypeLastCell).Row
vStartRow = vEndRow - 30
' DELETE OLD CHART IF EXISTS
NumCharts = ActiveSheet.ChartObjects.Count
For ic = NumCharts To 1 Step -1
If ActiveSheet.ChartObjects(ic).Name = sChartName Then
ActiveSheet.ChartObjects(ic).Delete
End If
Next ic
argL = 41: argT = 1010: argW = 500: argH = 300' CREATE!
DOCAA_FUNC_Chart_Builder ws, ws_name, sChartName, sTitle, vTrendLineVal, vStartRow, vEndRow, argL, argT, argW, argH

This procedure calls a chart creator function that draws the chart exactly the way I want it.

Sub DOCAA_FUNC_Chart_Builder(ws As Worksheet, ws_name, sChartName, sTitle, vTrendLineVal, vStartRow, vEndRow, argL, argT, argW, argH)Range("F2").Select ' we'll move later
ActiveSheet.Shapes.AddChart2(227, xlLine).Select
ActiveChart.Parent.Name = sChartName ' rename chart immediately!
ActiveSheet.ChartObjects(sChartName).Activate ' make sure chart activated
' Position chart
ActiveChart.Parent.Left = argL
ActiveChart.Parent.Top = argT
'Size Chart
ActiveChart.Parent.Width = argW
ActiveChart.Parent.Height = argH
' Column map:
' G = Date | H = New Hospitalizations | I = New Positives | J = Average Temp
' ***
' ADD DATA TO CHART BY CREATING SERIES FOR EACH
' ***
' FIRST SERIES, Create
ActiveSheet.ChartObjects(sChartName).Activate ' make sure chart activated
... etc etc...End Sub

The ease at which you can create trend lines is one of the many built-in features and makes Excel so powerful.

ANNOTATE

Excel doesn’t have a way to save a text box as an image. However, one can create a blank chart, add a text box, then save the chart to get the same result. I’m not using this step in this project (if this story is popular I’ll put it in later).

Sub DOCAA_s25_CHART_CreateExplainerGraphic()' DELETE
NumCharts = ActiveSheet.ChartObjects.Count
For ic = NumCharts To 1 Step -1
If ActiveSheet.ChartObjects(ic).Name = "uiExplainer" Then
ActiveSheet.ChartObjects(ic).Delete
End If
Next ic
Range("B52").Select
' Create Chart
Dim oChartObj As ChartObject
Set oChartObj = ActiveSheet.ChartObjects.Add(10, 10, 200, 200)
oChartObj.Select
ActiveChart.Parent.Name = "uiExplainer" ' Name Chart

ActiveChart.Parent.Cut

Range("B51").Select
ActiveSheet.Paste

ActiveSheet.ChartObjects("uiExplainer").Activate

ActiveSheet.Shapes("uiExplainer").Width = 500
ActiveSheet.Shapes("uiExplainer").Height = 300

ActiveSheet.ChartObjects("uiExplainer").Activate
ActiveChart.Shapes.AddTextbox(msoTextOrientationHorizontal, 6, 4.5, 488, 289). _
Select
Selection.ShapeRange(1).TextFrame2.TextRange.Characters.text = _
Range("slugExplainer").Value

iLenText = Len(Range("slugExplainer").Value)

ActiveChart.Shapes.Range(Array("TextBox 1")).Select
Selection.ShapeRange(1).TextFrame2.TextRange.Characters(iLenText, 1).Font.Size = 28
Selection.ShapeRange.TextFrame2.TextRange.Font.Size = 40
Selection.ShapeRange.TextFrame2.TextRange.Font.Bold = msoTrue
Selection.ShapeRange.TextFrame2.TextRange.ParagraphFormat.Alignment = _
msoAlignCenter
Selection.ShapeRange.TextFrame2.VerticalAnchor = msoAnchorMiddle
With Selection.ShapeRange(1).TextFrame2.TextRange.Characters(1, iLenText).Font.Fill
.Visible = msoTrue
.ForeColor.RGB = RGB(192, 0, 0)
.Transparency = 0
.Solid
End With

Range("H50").Select

End Sub

ANIMATE

Here I create GIFs of all the charts

Sub DOCAA_s30_Create_GIFs()Dim objChrt As ChartObject
Dim MyChart As Chart

myPath = Range("Images_Folder").Value
xcharts = Split(Range("ChartNames_To_Images").Value, ",")


For i = 0 To UBound(xcharts)

sChartName = Trim(xcharts(i))
sChartNamnGIF = sChartName & ".gif"

Set objChrt = ActiveSheet.ChartObjects(sChartName)
Set MyChart = objChrt.Chart

On Error Resume Next
Kill myPath & "\" & sChartNameGIF
On Error GoTo 0

MyChart.Export Filename:=myPath & "\Chart_" & Trim(Str(i + 1)) & ".gif", FilterName:="GIF"

Next
End Sub

Then I call Imagemagick’s “convert.exe” command-line app to create the animated GIF. Libraries for creating GIFs on PCs are limited. If I want to create something sophisticated I’ll upload my separate GIFs or PNGs and use an on-line GIF maker like EZGif.com.

Sub DOCAA_s35_Create_AnimatedGIF()
' Example:
'./convert -delay 200 -loop 0 Picture*.gif animate4.gif
sPath = Range("Images_Folder").Value
sCommand = sPath & "\" & "convert "
sParams = "-delay " & Range("ChartNames_To_Images").Value & " -loop 0 "
sFiles = Range("Images_Folder").Value & "\chart_*.gif "
sTarget = sPath & "\" & Range("slugAnimatedGIFName").Value
sRunString = sCommand & sParams & sFiles & sTarget
Debug.Print sRunString
Set WshShell = CreateObject("WScript.Shell")
WshShell.Run sRunString, 0
Set WshShell = Nothing
End Sub

BONUS

I shell out to WinSCP to upload (update) the images on any website.

Sub DOCAA_s40_uploadBySFTP()
' I used WinSCP Session | Generate Session URL/Code... to figure these settings
' Put all commands for after host connection in here
sScriptFile = "C:\Files2020_Analytics\Excel\DOCAA\HTMLPages\WinSCP_Script.txt"
' saves to:
' https://maxdatabook.com/staticpages/docaa_example01.html
sWinSCP = "C:\Program Files (x86)\WinSCP\WinSCP.exe"
sWinSCPGeneratedScript = " /ini=nul /script=" & Chr(34) & sScriptFile & Chr(34)
sCmd = Chr(34) & sWinSCP & Chr(34) & sWinSCPGeneratedScript
Debug.Print sCmdDim script As Object: Set script = VBA.CreateObject("WScript.Shell")
Dim waitOnReturn As Boolean: waitOnReturn = True
Dim windowStyle As Integer: windowStyle = 1
'Execute script
script.Run sCmd, windowStyle, waitOnReturn

End Sub

CONCLUSION

Using Excel, we can automate the creation of charts, and explainer slides, from which we can use separately, or combine into an animated GIF. We can then update our website with the updated charts.

I’m an independent software consultant/developer and can be reached at maxdatabook.com