by Oliver French (1 Submission)
Category: Microsoft Office Apps/VBA
Compatability: Visual Basic 5.0
Difficulty: Intermediate
Date Added: Wed 3rd February 2021
Rating: 
(13 Votes)
This function takes a three dimensional array of data with four parameters to track trends as they vary along two variables, opens a new instance of Excel, enters the data in three Excel worksheets, then creates charts of one of the data sets. One chart is a three dimensional surface type. In this case, it was desired to show the Q of an inductive winding at differing frequencies and with a metal target at varying distances from the winding.
Inputs
A three dimensional array. In this case, the first dimension is set as [Distance],[Frequency],[Q],[Inductance],and [dQ/dResistance]. The distance parameter varies along the second dimension, and the frequency parameter varies along the third dimension.
Code Returns
The function does not return any values - error checking should be added to return a boolean indicating if any errors occurred.
VBcoders' ********************************************************************************
' ********************************************************************************
' ** Save and chart a 3D array of data in excel **
' ********************************************************************************
' ********************************************************************************
Public Function Chart3DArray(varData As Variant)
Dim xlApp As Excel.Application
Dim xlBook As Excel.Workbook
Dim xlQSheet As Excel.Worksheet
Dim xlLSheet As Excel.Worksheet
Dim xlRSheet As Excel.Worksheet
Dim SFile As String
Dim intQStartRow As Integer
Dim intDQStartRow As Integer
Dim intLStartRow As Integer
Dim intRStartRow As Integer
Dim xl3DChart As Excel.Chart
Dim xl2DChart As Excel.Chart
Dim d%, f%
Set xlApp = New Excel.Application ' Create new instance of excel
xlApp.Visible = False
Set xlBook = xlApp.Workbooks.Add
' Name sheets
xlBook.Sheets("Sheet1").Name = "Q"
xlBook.Sheets("Sheet2").Name = "L"
xlBook.Sheets("Sheet3").Name = "R"
' Load sheet objects
Set xlQSheet = xlApp.Worksheets("Q")
Set xlLSheet = xlApp.Worksheets("L")
Set xlRSheet = xlApp.Worksheets("R")
' Load start row variables to keep track of which row data is being entered in
intQStartRow = 3
xlQSheet.Cells(intQStartRow - 2, 1) = "Q Data"
intDQStartRow = UBound(varData, 2) + intQStartRow + 4
xlQSheet.Cells(intDQStartRow - 2, 1) = "dQ/dD (Slopes are calculate over 1mm intervals)"
intLStartRow = 3
xlLSheet.Cells(intLStartRow - 2, 1) = "L Data (mHenries)"
intRStartRow = 3
xlRSheet.Cells(intRStartRow - 2, 1) = "R Data (ohms)"
' Populate sheet with data
For d% = 0 To UBound(varData, 2)
xlQSheet.Cells(d% + intQStartRow, 1) = varData(0, d%, 0) & "mm"
xlQSheet.Cells(intDQStartRow + d%, 1) = varData(0, d%, 0) & "mm"
xlLSheet.Cells(d% + intLStartRow, 1) = varData(0, d%, 0) & "mm"
xlRSheet.Cells(d% + intRStartRow, 1) = varData(0, d%, 0) & "mm"
Next d%
For f% = 0 To UBound(varData, 3)
xlQSheet.Cells(intQStartRow - 1, 2 + f%) = varData(1, 0, f%) & "kHz"
xlQSheet.Cells(intDQStartRow - 1, 2 + f%) = varData(1, 0, f%) & "kHz"
xlLSheet.Cells(intLStartRow - 1, 2 + f%) = varData(1, 0, f%) & "kHz"
xlRSheet.Cells(intRStartRow - 1, 2 + f%) = varData(1, 0, f%) & "kHz"
For d% = 0 To UBound(varData, 2)
xlQSheet.Cells(d% + intDQStartRow, 2 + f%) = varData(5, d%, f%)
xlQSheet.Cells(d% + intQStartRow, 2 + f%) = varData(2, d%, f%)
xlLSheet.Cells(d% + intLStartRow, 2 + f%) = varData(3, d%, f%)
xlRSheet.Cells(d% + intRStartRow, 2 + f%) = varData(4, d%, f%)
Next d%
Next f%
' Plot 3d Chart of Q
xlApp.Charts.Add
Set xl3DChart = xlApp.ActiveChart
xl3DChart.SetSourceData Source:=xlBook.Sheets("Q").Range(xlQSheet.Cells(intQStartRow, 1), _
xlQSheet.Cells(intQStartRow + UBound(varData, 2), UBound(varData, 3) + 2)), PlotBy:=xlColumns
For f% = 0 To UBound(varData, 3)
xl3DChart.SeriesCollection(f% + 1).Name = CStr(varData(1, 0, f%)) & " kHz"
Next f%
xl3DChart.Location Where:=xlLocationAsNewSheet, Name:="Q 3D Chart Temp"
With xl3DChart
.HasTitle = True
.ChartTitle.Characters.Text = "Core Analysis"
.Axes(xlCategory).HasTitle = True
.Axes(xlCategory).AxisTitle.Characters.Text = "Distance"
.ChartType = xlSurface
.Axes(xlSeries).HasTitle = True
.Axes(xlSeries).AxisTitle.Characters.Text = "Frequency"
.Axes(xlValue).HasTitle = True
.Axes(xlValue).AxisTitle.Characters.Text = "Q"
End With
' Copy the same chart then change original to x-y scatter with smoothed lines
xlBook.Sheets("Q 3D Chart Temp").Copy Before:=xlBook.Sheets("Q 3D Chart Temp")
xlBook.Sheets("Q 3D Chart Temp (2)").Name = "Q Chart 3D"
xl3DChart.ChartType = xlLineMarkers
With xl3DChart.PlotArea.Border
.ColorIndex = 16
.Weight = xlThin
.LineStyle = xlContinuous
End With
xl3DChart.PlotArea.Fill.OneColorGradient Style:=1, Variant:=1, _
Degree:=0.231372549019608
With xl3DChart.PlotArea
.Fill.Visible = True
.Fill.ForeColor.SchemeColor = 17
End With
xlBook.Sheets("Q 3D Chart Temp").Name = "2D Q Chart"
' Plot 2d Chart of dQ/dD
xlApp.Charts.Add
Set xl2DChart = xlApp.ActiveChart
xl2DChart.SetSourceData Source:=xlBook.Sheets("Q").Range(xlQSheet.Cells(intDQStartRow, 1), _
xlQSheet.Cells(intDQStartRow + UBound(varData, 2), UBound(varData, 3) + 2)), PlotBy:=xlColumns
For f% = 0 To UBound(varData, 3)
xl2DChart.SeriesCollection(f% + 1).Name = CStr(varData(1, 0, f%)) & " kHz"
Next f%
xl2DChart.Location Where:=xlLocationAsNewSheet, Name:="dQdD Chart"
With xl2DChart
.HasTitle = True
.ChartTitle.Characters.Text = "Core Analysis"
.Axes(xlCategory).HasTitle = True
.Axes(xlCategory).AxisTitle.Characters.Text = "Distance"
.ChartType = xlLineMarkers
.Axes(xlValue).HasTitle = True
.Axes(xlValue).AxisTitle.Characters.Text = "dQ/dD"
End With
With xl2DChart.PlotArea.Border
.ColorIndex = 16
.Weight = xlThin
.LineStyle = xlContinuous
End With
xl2DChart.PlotArea.Fill.OneColorGradient Style:=1, Variant:=1, _
Degree:=0.231372549019608
With xl2DChart.PlotArea
.Fill.Visible = True
.Fill.ForeColor.SchemeColor = 17
End With
' Save file
With frmSensorSetup.dlgSave
.DialogTitle = "Save"
.CancelError = False
.Filter = "Excel Workbooks (*.xls)|*.xls"
.ShowSave
If Len(.FileName) = 0 Then
MsgBox "Enter a valid name"
Else
SFile = .FileName
End If
End With
xlBook.SaveAs (SFile)
xlBook.Close
xlApp.Quit
' Clear objects from memory
Set xlQSheet = Nothing
Set xlLSheet = Nothing
Set xlRSheet = Nothing
Set xlBook = Nothing
Set xlApp = Nothing
End Function
