Creating Animated Chart GIFs with Excel VBA

Configs for working with many kinds of data and parameters.

Data

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
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

ORGANIZE

CHART

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
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

ANNOTATE

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

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
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

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

--

--

Get the Medium app

A button that says 'Download on the App Store', and if clicked it will lead you to the iOS App store
A button that says 'Get it on, Google Play', and if clicked it will lead you to the Google Play store