Getting the range used to define error bars with VBA

Question

I have an Excel chart. One of the series has X and Y error bars, defined from worksheet ranges.

I want to get via VBA those ranges (not set them). Is this possible?

Answer 1

Jon Peltier has an article about error bars on his blog here

Quoting from that:

Programmatically Defining Custom Error Bars

The command to add error bars using Excel is: {Series}.ErrorBar Direction:={xlX or xlY}, Include:=xlBoth, Type:=xlCustom, _ Amount:={positive values}, MinusValues:={negative values} Values can be a single numerical value, for example, 1, an comma-separated array of numerical values in curly braces, such as {1,2,3,4}, or a range address in R1C1 notation. For values in Sheet1!$G$2:$G$10, enter the address as Sheet1!R2C7:R10C7. Combine both plus and minus in the same command. In Excel 2007, if you don't want to show a particular error bar, you must enter a value of zero in this command. In 2003, you can enter a null string “”. In Excel 2003, the range address must begin with an equals sign, =Sheet1!R2C7:R10C7; Excel 2007 accepts the address with or without the equals sign. Single values or arrays may be entered with or without the equals sign in either version of Excel.

In a post on Ozgrid , Jon Peltier says

the range for custom error bar values is not exposed to VBA

If Jon says it can't be done, it can't be done.

Answer 2

I know I'm 8 years late to the party here... but I stumbled upon this while scouring the web for the answer to this same question. I came up empty too, so I decided to devise my own solution, and figured I might as well post it on the off chance that someone else ends up here.

It works by extracting the workbook XML to a temporary folder, locating the error bar reference in the XML, and returning it as a Range object. You therefore have to save changes to the workbook before the function will work. If you change the error bar range without saving, the function will still return the old range from the most recent save. It also will not work on files from Excel 2003 or earlier (.xls).

It's anything but elegant... but at least this is technically possible!

To use: just copy the code below into a standard module, and call GetErrorBarRange(MySeries.ErrorBars, enErrorBarPlus) for the source range of the positive error bar, or GetErrorBarRange(MySeries.ErrorBars, enErrorBarMinus) for the source range of the negative error bar (where MySeries.ErrorBars is some ErrorBars object). Passing the optional third argument AutoSave:=True will save the containing workbook automatically before looking for the error bar source ranges.

' Created by Ryan T. Miller in 2022
' You may use this code in your own work however you wish. It'd be real swell of you
' to leave this credit in if you do, but I'm not gonna force you to.

Option Explicit
Option Private Module

Public Enum EnErrorBarPlusMinus
    enErrorBarPlus
    enErrorBarMinus
End Enum
Private moFSO As Object

' Get error bar source range from ErrorBars object
Public Function GetErrorBarRange(oErrorBars As ErrorBars, _
        PlusMinus As EnErrorBarPlusMinus, _
        Optional AutoSave As Boolean) As Range
    Dim oFile As Object
    Dim strTempDir As String
    Dim strSubfolder As String
   
    Dim oSeries As Series
    Dim oChart As Chart
    Dim oSheet As Object
    Dim oWb As Workbook
    Dim strPrefix As String
   
    Dim strSeriesName As String
    Dim strChartName As String
    Dim strSheetName As String
   
    Dim strXMLFile As String
    Dim strXPath As String
    Dim strCurrentSheet As String
    Dim strRelId As String
    Dim strDrawingXml As String
    Dim strChartXml As String
    Dim strErrValType As String
    Dim strErrBarType As String
   
    Dim strErrBarFormula As String
    Dim rngResult As Range
    On Error GoTo CleanUp
   
    If Not (PlusMinus = enErrorBarMinus _
            Or PlusMinus = enErrorBarPlus) Then Exit Function
   
    Set moFSO = CreateObject("Scripting.FileSystemObject")
    Application.Cursor = xlWait
   
    ' Set Series, Chart, Sheet, and Workbook objects
    Set oSeries = oErrorBars.Parent
    Set oChart = oSeries.Parent.Parent
    If TypeOf oChart.Parent Is ChartObject Then
        ' Chart is on a worksheet
        Set oSheet = oChart.Parent.Parent
        strPrefix = "work"
    Else
        ' Chart is on its own chart sheet
        Set oSheet = oChart
        strPrefix = "chart"
    End If
    Set oWb = oSheet.Parent
    If AutoSave Then oWb.Save
   
    ' Name of the series, chart & its parent sheet
    strSeriesName = oSeries.Name
    strChartName = oChart.Parent.Name
    strSheetName = oSheet.CodeName

    strTempDir = ExtractWorkbookXMLToTemp(oWb)
   
    ' Loop over worksheet/chartsheet XML files & find the one where /worksheet/sheetPr/@codeName=strSheetName
    ' Then get strRelId from /worksheet/drawing/@r:id
    ' This is the ID which specifies which relationship links the sheet to the drawings.
    strSubfolder = moFSO.BuildPath(strTempDir, "xl\" & strPrefix & "sheets")
    strXPath = "/x:" & strPrefix & "sheet/x:sheetPr/@codeName"
    For Each oFile In moFSO.GetFolder(strSubfolder).Files
        strXMLFile = moFSO.BuildPath(strSubfolder, oFile.Name)
        strCurrentSheet = GetXPathFromXMLFile(strXMLFile, strXPath)
        If strSheetName = strCurrentSheet Then Exit For
    Next oFile
    strXPath = "/x:" & strPrefix & "sheet/x:drawing/@r:id"
    strRelId = GetXPathFromXMLFile(strXMLFile, strXPath)
   
    ' Open the _rels XML associated with the correct sheet.
    ' Then get strDrawingXml from /Relationships/Relationship[@Id='strRelId']/@Target
    ' This is the name of the drawing XML.
    strSubfolder = strSubfolder & "\_rels"
    strXMLFile = moFSO.BuildPath(strSubfolder, moFSO.GetFileName(strXMLFile)) & ".rels"
    strXPath = "/rel:Relationships/rel:Relationship[@Id='" & strRelId & "']/@Target"
    strDrawingXml = GetXPathFromXMLFile(strXMLFile, strXPath)
    strDrawingXml = Replace$(Replace$(strDrawingXml, "../", "/"), "/", "\")
   
    ' Open the correct drawing XML file (strDrawingXml)
    ' Then get strRelId from xdr:wsDr//xdr:graphicFrame[xdr:nvGraphicFramePr/xdr:cNvPr/@name='strChartName']/a:graphic/a:graphicData/c:chart/@r:id
    ' Or, if oSheet is a ChartSheet, there will only be 1 chart, so just get xdr:wsDr//xdr:graphicFrame/a:graphicData/a:graphic/c:chart/@r:id
    ' This is the ID which specifies which relationship links the drawing to the chart.
    strXMLFile = moFSO.BuildPath(strTempDir, "xl" & strDrawingXml)
    strXPath = "xdr:wsDr//xdr:graphicFrame" & _
            IIf(TypeOf oChart.Parent Is ChartObject, "[xdr:nvGraphicFramePr/xdr:cNvPr/@name='" & strChartName & "']", vbNullString) & _
            "/a:graphic/a:graphicData/c:chart/@r:id"
    strRelId = GetXPathFromXMLFile(strXMLFile, strXPath)
   
    ' Open the _rels associated with the correct drawing XML.
    ' Then get strChartXml = /Relationships/Relationship[@Id='strRelId']/@Target
    ' This is the name of the chart XML.
    strSubfolder = moFSO.GetParentFolderName(strXMLFile) & "\_rels"
    strXMLFile = moFSO.BuildPath(strSubfolder, moFSO.GetFileName(strXMLFile)) & ".rels"
    strXPath = "/rel:Relationships/rel:Relationship[@Id='" & strRelId & "']/@Target"
    strChartXml = GetXPathFromXMLFile(strXMLFile, strXPath)
    strChartXml = Replace$(Replace$(strChartXml, "../", "/"), "/", "\")
   
    ' Open the correct chart XML file (strChartXml)
    strXMLFile = moFSO.BuildPath(strTempDir, "xl" & strChartXml)
   
    ' Get error bar value type. If the error bar is set to a Range then this must be 'cust'.
    strXPath = "/c:chartSpace/c:chart//c:ser[c:tx//c:v[text()='" & strSeriesName & "']]/c:errBars/c:errValType/@val"
    strErrValType = GetXPathFromXMLFile(strXMLFile, strXPath)
   
    ' Get error bar type. This can be "minus", "plus", or "both" depending on which error bar(s) exist(s).
    strXPath = "/c:chartSpace/c:chart//c:ser[c:tx//c:v[text()='" & strSeriesName & "']]/c:errBars/c:errBarType/@val"
    strErrBarType = GetXPathFromXMLFile(strXMLFile, strXPath)
   
    ' Get the Range address for either the "minus" or "plus" error bar and set it to the final result.
    If strErrValType = "cust" Then
        strXPath = "/c:chartSpace/c:chart//c:ser[c:tx//c:v[text()='" & strSeriesName & "']]/c:errBars"
        If PlusMinus = enErrorBarMinus And (strErrBarType = "both" Or strErrBarType = "minus") Then
            strXPath = strXPath & "/c:minus/c:numRef/c:f"
        ElseIf PlusMinus = enErrorBarPlus And (strErrBarType = "both" Or strErrBarType = "plus") Then
            strXPath = strXPath & "/c:plus/c:numRef/c:f"
        EndIf
        strErrBarFormula = GetXPathFromXMLFile(strXMLFile, strXPath)
        strErrBarFormula = "'[" & oWb.Name & "]" & Replace$(strErrBarFormula, "!", "'!")
        Set rngResult = Application.Range(strErrBarFormula)
    End If
    Set GetErrorBarRange = rngResult
   
CleanUp:
    ' Delete the temporary extracted XML data
    With moFSO
        If .FolderExists(strTempDir) Then .DeleteFolder strTempDir
    End With
    Set moFSO = Nothing

    ' Free the cursor
    Application.Cursor = xlDefault
   
End Function


' Get the value of an XML node by an XPath search string
Private Function GetXPathFromXMLFile(ByVal strXMLFile As String, ByVal strXPath As String) As String
    Dim objXMLDoc As Object
    Dim strNS As String
    Dim objXMLNode As Object

    ' Load the XML file
    Set objXMLDoc = CreateObject("MSXML2.DOMDocument.6.0")
    objXMLDoc.Load strXMLFile
   
    ' These are all the XML namespaces related to the current task
    strNS = Join$(Array( _
        "xmlns:x=""http://schemas.openxmlformats.org/spreadsheetml/2006/main""", _
        "xmlns:r=""http://schemas.openxmlformats.org/officeDocument/2006/relationships""", _
        "xmlns:mc=""http://schemas.openxmlformats.org/markup-compatibility/2006""", _
        "xmlns:x14ac=""http://schemas.microsoft.com/office/spreadsheetml/2009/9/ac""", _
        "xmlns:xr=""http://schemas.microsoft.com/office/spreadsheetml/2014/revision""", _
        "xmlns:xr2=""http://schemas.microsoft.com/office/spreadsheetml/2015/revision2""", _
        "xmlns:xr3=""http://schemas.microsoft.com/office/spreadsheetml/2016/revision3""", _
        "xmlns:rel=""http://schemas.openxmlformats.org/package/2006/relationships""", _
        "xmlns:xdr=""http://schemas.openxmlformats.org/drawingml/2006/spreadsheetDrawing""", _
        "xmlns:a=""http://schemas.openxmlformats.org/drawingml/2006/main""", _
        "xmlns:c=""http://schemas.openxmlformats.org/drawingml/2006/chart""", _
        "xmlns:c16r2=""http://schemas.microsoft.com/office/drawing/2015/06/chart""" _
    ))
    objXMLDoc.SetProperty "SelectionLanguage", "XPath"
    objXMLDoc.SetProperty "SelectionNamespaces", strNS
    objXMLDoc.resolveExternals = True
   
    ' Select the XML node and return its text value
    Set objXMLNode = objXMLDoc.SelectSingleNode(strXPath)
    If Not objXMLNode Is Nothing Then
        GetXPathFromXMLFile = objXMLNode.Text
    End If
   
End Function


' If workbook path is a OneDrive URL or a network share URL then resolve it to a local path with a drive letter
Private Function LocalFilePath(ByVal strFilePath As String)
    strFilePath = OneDriveLocalFilePath(strFilePath)
    strFilePath = NetworkLocalFilePath(strFilePath)
    LocalFilePath = strFilePath
End Function


' If workbook path is a OneDrive URL then resolve it to a local path with a drive letter
Private Function OneDriveLocalFilePath(ByVal strFilePath As String) As String
    Dim strOneDrivePath As String
    Dim strLocalPath As String
   
    If strFilePath Like "*my.sharepoint.com*" Then
        strOneDrivePath = Environ$("OneDriveCommercial")
        If strOneDrivePath = vbNullString Then strOneDrivePath = Environ$("OneDrive")
        strLocalPath = strOneDrivePath & "/" & Split(strFilePath, "/", 7)(6)
        OneDriveLocalFilePath = Replace$(strLocalPath, "/", "\")
       
    ElseIf strFilePath Like "*d.docs.live.net*" Then
        strOneDrivePath = Environ$("OneDriveConsumer")
        If strOneDrivePath = vbNullString Then strOneDrivePath = Environ$("OneDrive")
        strLocalPath = strOneDrivePath & "/" & Split(strFilePath, "/", 5)(4)
        OneDriveLocalFilePath = Replace$(strLocalPath, "/", "\")
       
    Else
        OneDriveLocalFilePath = strFilePath
    End If
End Function


' If workbook path is a network share URL then resolve it to a local path with a drive letter
Private Function NetworkLocalFilePath(ByVal strFilename As String) As String
On Error Resume Next

    Dim ShellScript As Object
    Dim i As Long
    Dim strDriveLetter As String * 1
    Dim strRemotePath As String
   
    Set ShellScript = CreateObject("WScript.Shell")
    For i = 97 To 122   ' a to z
        strDriveLetter = Chr$(i)
        strRemotePath = ShellScript.RegRead("HKEY_CURRENT_USER\Network\" & strDriveLetter & "\RemotePath")
        If Err.Number = 0 Then
            If strFilename Like strRemotePath & "*" Then
                NetworkLocalFilePath = Replace$(strFilename, strRemotePath, UCase$(strDriveLetter) & ":", Count:=1)
                Exit Function
            End If
        Else
            Err.Clear
        End If
    Next i
    NetworkLocalFilePath = strFilename
End Function


' Extract workbook XML to temporary directory
Private Function ExtractWorkbookXMLToTemp(oWb As Workbook) As String
    Dim strTempDir As String
    Dim strExt As String
    Dim strTempWb As String
    Dim strWbLocal As String
    Dim strZipFile As String
    On Error GoTo CleanUp

    ' Create a temporary copy of the workbook
    With moFSO
        strTempDir = .BuildPath(Environ$("TEMP"), _
                Replace$(.GetTempName, ".tmp", vbNullString))
        strExt = .GetExtensionName(oWb.Name)
        strTempWb = strTempDir & "." & strExt
        strWbLocal = LocalFilePath(oWb.FullName)
        .CopyFile strWbLocal, strTempWb
    End With
   
    ' Rename the temporary copy from .xls_ to .zip
    strZipFile = strTempDir & ".zip"
    Name strTempWb As strZipFile
   
    ' Unzip the .zip file to a temporary folder
    MkDir strTempDir
    UnzipFiles strZipFile, strTempDir
   
    ' Return the name of the temporary directory
    ExtractWorkbookXMLToTemp = strTempDir
   
CleanUp:
    ' Delete the temporary ZIP file
    With moFSO
        If .FileExists(strZipFile) Then .DeleteFile strZipFile
    End With
   
End Function


' Unzip all the files in 'varZipFile' into the folder 'varDestDir'
Private Sub UnzipFiles(ByVal varZipFile As Variant, ByVal varDestDir As Variant)
    Dim oShellApp As Object
    Const NO_PROGRESS_DIALOG As Integer = &H4
   
    Set oShellApp = CreateObject("Shell.Application")
   
    If Not varDestDir Like "*\" Then varDestDir = varDestDir & "\"
    With oShellApp
        .Namespace(varDestDir).CopyHere .Namespace(varZipFile).Items, NO_PROGRESS_DIALOG
    End With
   
    On Error Resume Next
    With oShellApp
        Do Until .Namespace(varZipFile).Items.Count = .Namespace(varDestDir).Items.Count
            Application.Wait Date + (VBA.Timer + 1!) / 86400
        Loop
    End With
    On Error GoTo 0
End Sub