KSR-logo

Healthcare Data Communication Expert


from Visualizing Data: How to Make a Soda Chart

Here's the full VBA with comments added:

Private strChartTitle As String
Private strChartType As String
Private iEndRowForSrcData As String
Private iCntValCols As Integer 'counts number of value cols in Source worksheet

Private Sub Generate_Table_And_Chart_Click()
	Application.DisplayAlerts = False
	Generate_Table_Chart_Worksheets 'create the Table and if they're not already there
	Generate_Table 'produce the table of triplets from the crosstab
	Generate_Bubble_Chart 'we don't fully understand why, but this has to be
	Generate_Bubble_Chart 'called twice to make the chart produce properly
	ThisWorkbook.Save
End Sub

Private Sub Generate_Table_Chart_Worksheets()
	Dim iShtToDelete As Integer
	Dim StrWkshtNameArr(1 To 2) As String

	StrWkshtNameArr(1) = "Chart"
	StrWkshtNameArr(2) = "Table"

	'ensure that second sheet is called Update, in case anyone changes it
	If ThisWorkbook.Worksheets(2).Name <> "Update" Then
		ThisWorkbook.Worksheets(2).Name = "Update"
	End If

	iShtToDelete = 3

	'delete table and chart worksheets (if they exist)
	For iWkShtCnt = iShtToDelete To ThisWorkbook.Worksheets.Count
		ThisWorkbook.Worksheets(iShtToDelete).Delete
	Next iWkShtCnt

	'Add table and chart worksheets
	For iWkShtCnt = 1 To 2
		Worksheets.Add(after:=ThisWorkbook.Worksheets("Update")).Name = StrWkshtNameArr(iWkShtCnt)
	Next iWkShtCnt
End Sub
Private Sub Generate_Table()
	Dim StrColHdgsArr(1 To 3) As String
	Dim iPosToAddHdg As Integer
	Dim iXAxisDataPointCount As Integer
	Dim iColForAgeHdg_SrcWksht As Integer
	Dim iStartColForValHdg_SrcWksht As Integer

	'clear chart worksheet to allow for updates from source sheet
	ThisWorkbook.Worksheets("Table").Cells.Clear

	On Error Resume Next
	strChartType = "Bbl_Chrt"
	Set ChartObject = Worksheets("Chart").ChartObjects(strChartType)
	If Not ChartObject Is Nothing Then
		ThisWorkbook.Worksheets("Chart").ChartObjects(strChartType).Delete
	End If

	strChartTitle = "Chart Title?"

	'Will always be 3 headings!
	StrColHdgsArr(1) = "XTitle"
	StrColHdgsArr(2) = "YTitle"
	StrColHdgsArr(3) = "Value"

	iEndRowForSrcData = ThisWorkbook.Worksheets("Source").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

	'do not copy Grand Total row from Source worksheet
	If Not IsNumeric(ThisWorkbook.Worksheets("Source").Cells(iEndRowForSrcData, 1)) Then
		iEndRowForSrcData = iEndRowForSrcData - 1
	End If

	For iColCnt = 1 To ThisWorkbook.Worksheets("Source").Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
		If LCase(Trim(ThisWorkbook.Worksheets("Source").Cells(1, iColCnt))) = "age" Then
			iColForAgeHdg_SrcWksht = iColCnt
		End If
	Next iColCnt

	iStartColForValHdg_SrcWksht = iColForAgeHdg_SrcWksht + 1

	iPosToAddHdg = 1
	iXAxisDataPointCount = 1
	iCntValCols = 0

	'count no of value cols as measurement could vary e.g., hr of day = 24hrs (24 cols), days of week (5 cols), etc
	For iColCnt = 1 To ThisWorkbook.Worksheets("Source").Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
		If IsNumeric(ThisWorkbook.Worksheets("Source").Cells(1, iColCnt)) Then 'only count numerical vals
			iCntValCols = iCntValCols + 1
		End If
	Next iColCnt


	With ThisWorkbook.Worksheets("Table")
		For iColCnt = 1 To iCntValCols
			For iColHdgCnt = LBound(StrColHdgsArr) To UBound(StrColHdgsArr)
				.Cells(1, iPosToAddHdg) = StrColHdgsArr(iColHdgCnt)

				For iRowCnt = 2 To iEndRowForSrcData
					If iColHdgCnt = 1 Then 'hour
						.Cells(iRowCnt, iPosToAddHdg) = iXAxisDataPointCount
						.Cells(1, iPosToAddHdg).Interior.ColorIndex = 34
						.Cells(iRowCnt, iPosToAddHdg).Interior.ColorIndex = 34
					End If
					If iColHdgCnt = 2 Then 'age
						.Cells(iRowCnt, iPosToAddHdg) = ThisWorkbook.Worksheets("Source").Cells(iRowCnt, iColForAgeHdg_SrcWksht)
						.Cells(1, iPosToAddHdg).Interior.ColorIndex = 40
						.Cells(iRowCnt, iPosToAddHdg).Interior.ColorIndex = 40
					End If
					If iColHdgCnt = 3 Then 'val
						.Cells(iRowCnt, iPosToAddHdg) = ThisWorkbook.Worksheets("Source").Cells(iRowCnt, iStartColForValHdg_SrcWksht)
						.Cells(1, iPosToAddHdg).Interior.ColorIndex = 36
						.Cells(iRowCnt, iPosToAddHdg).Interior.ColorIndex = 36
					End If
				Next iRowCnt

				iPosToAddHdg = iPosToAddHdg + 1
			Next iColHdgCnt
			iXAxisDataPointCount = iXAxisDataPointCount + 1
			iStartColForValHdg_SrcWksht = iStartColForValHdg_SrcWksht + 1
		Next iColCnt
	End With

	Erase StrColHdgsArr
End Sub
Private Sub Generate_Bubble_Chart()
	Dim iChartTop As Integer
	Dim iChartLeft As Integer
	Dim iChartHeight As Integer
	Dim iChartWidth As Integer
	Dim iSeriesXValCol As Integer
	Dim strSeriesXValCol As String
	Dim iSeriesYValCol As Integer
	Dim strSeriesYValCol As String
	Dim iSeriesDataPtCol As Integer
	Dim strSeriesDataPtCol As String
	Dim iSeriesCnt As Integer
	Dim iEndColForDataPoint As Integer

	iChartTop = 10
	iChartLeft = 5
	iChartHeight = 400
	iChartWidth = 560

	ThisWorkbook.Worksheets("Chart").Select

	On Error Resume Next
	Set ChartObject = ActiveWorkbook.Worksheets("Chart").ChartObjects(strChartType)
	If ChartObject Is Nothing Then
		Set ChartObject = ActiveWorkbook.Worksheets("Chart").ChartObjects.Add(Left:=iChartLeft, Width:=iChartWidth, Top:=iChartTop, Height:=iChartHeight)
		ChartObject.Name = strChartType
	End If

	ThisWorkbook.Worksheets("Chart").ChartObjects(strChartType).Select

	If Not ActiveChart Is Nothing Then
		With ActiveChart
			.HasTitle = True
			.HasLegend = False
			.ChartArea.Interior.ColorIndex = 19
			.PlotArea.Interior.Color = vbWhite
			.PlotArea.Border.LineStyle = xlNone
			.PlotArea.Width = iChartWidth * 0.88
			.PlotArea.Height = iChartHeight * 0.84
			.PlotArea.Top = 40
			.PlotArea.Left = 40
			.ChartTitle.Text = strChartTitle
			.ChartTitle.Font.Size = 11
			.ChartTitle.Font.Bold = True
			.ChartTitle.Font.Name = "Tahoma"

			'iCntValCols series to add (3 variables per series)
			'therefore iEndColForDataPoint = 3 * iCntValCols
			iEndColForDataPoint = 3 * iCntValCols

			iSeriesCnt = 1
			For iColCnt = 1 To iEndColForDataPoint Step 3
				iSeriesXValCol = iColCnt
				iSeriesYValCol = iColCnt + 1
				iSeriesDataPtCol = iColCnt + 2


				'convert iSeriesXValCol, iSeriesYValCol, and iSeriesDataPtCol to their string equivalents to allow range object of chart to be defined
				If iSeriesXValCol > 26 Then
					strSeriesXValCol = Chr(Int((iSeriesXValCol - 1) / 26) + 64) & Chr(((iSeriesXValCol - 1) Mod 26) + 65)
				Else
					strSeriesXValCol = Chr(iSeriesXValCol + 64)
				End If

				If iSeriesYValCol > 26 Then
					strSeriesYValCol = Chr(Int((iSeriesYValCol - 1) / 26) + 64) & Chr(((iSeriesYValCol - 1) Mod 26) + 65)
				Else
					strSeriesYValCol = Chr(iSeriesYValCol + 64)
				End If

				If iSeriesDataPtCol > 26 Then
					strSeriesDataPtCol = Chr(Int((iSeriesDataPtCol - 1) / 26) + 64) & Chr(((iSeriesDataPtCol - 1) Mod 26) + 65)
				Else
					strSeriesDataPtCol = Chr(iSeriesDataPtCol + 64)
				End If

				.SeriesCollection.NewSeries
				.ChartType = xlBubble
				.SeriesCollection(iSeriesCnt).XValues = Sheets("Table").Range("$" & strSeriesXValCol & "$2:$" & strSeriesXValCol & iEndRowForSrcData)
				.SeriesCollection(iSeriesCnt).Values = Sheets("Table").Range("$" & strSeriesYValCol & "$2:$" & strSeriesYValCol & iEndRowForSrcData)
				.SeriesCollection(iSeriesCnt).BubbleSizes = "=Table!R2C" & iSeriesDataPtCol & ":R70C" & iSeriesDataPtCol
				.SeriesCollection(iSeriesCnt).Border.ColorIndex = 1
				.SeriesCollection(iSeriesCnt).Interior.ColorIndex = 34
				.ChartGroups(1).BubbleScale = 15

				iSeriesCnt = iSeriesCnt + 1
			Next iColCnt

			With .Axes(xlValue, xlPrimary)
				.HasTitle = True
				.AxisTitle.Text = "YTitle?"
				.AxisTitle.Font.Size = 10
				.AxisTitle.Font.Bold = False
				.AxisTitle.Font.Name = "Tahoma"
				.AxisTitle.Font.ColorIndex = 1
				.AxisTitle.Left = 1
				.AxisTitle.Orientation = xlHorizontal
				.MajorGridlines.Border.ColorIndex = 15
			End With

			With .Axes(xlValue, xlPrimary)
				.MinimumScale = 0
				.MaximumScale = 100
				.MajorUnit = 10
			End With

			With .Axes(xlCategory).TickLabels
				.Font.Size = 10
				.Font.Name = "Tahoma"
				.Font.Bold = False
				.Font.ColorIndex = 56
				.Orientation = 0
			End With

			With .Axes(xlCategory)
				.HasTitle = True
				.AxisTitle.Text = "XTitle?"
				.AxisTitle.Font.Size = 10
				.AxisTitle.Font.Bold = False
				.AxisTitle.Font.Name = "Tahoma"
				.AxisTitle.Font.ColorIndex = 1
				.MinimumScale = 0
				.MaximumScale = iCntValCols + 1 'add one so that right hand side of bubble is not cut off
				.MajorUnit = 1
			End With

			With .Axes(xlSecondary).TickLabels
				.Font.Size = 10
				.Font.Name = "Tahoma"
				.Font.Bold = False
				.Font.ColorIndex = 56
			End With
		End With
	Else
		MsgBox "Please select a chart and try again.", _
		vbExclamation, "No Chart Selected"
	End If
End Sub