使用VBA获取用于定义误差线的范围

问题描述 投票:0回答:3

我有一个 Excel 图表。其中一个系列具有 X 和 Y 误差线,从工作表范围定义。

我想通过 VBA 获取这些范围(而不是设置它们)。这可能吗?

excel charts vba
3个回答
3
投票

Jon Peltier 在他的博客上有一篇关于误差线的文章这里

引述:

以编程方式定义自定义误差线

使用Excel添加误差线的命令是:{Series}.ErrorBar 方向:={xlX 或 xlY},包含:=xlBoth,类型:=xlCustom,_ 金额:={正值},减值:={负值} 值可以是单个数值,例如 1,以逗号分隔 大括号中的数值数组,例如 {1,2,3,4},或 R1C1 表示法中的范围地址。对于 Sheet1!$G$2:$G$10 中的值,输入 地址为 Sheet1!R2C7:R10C7。将加号和减号合并起来 相同的命令。在 Excel 2007 中,如果您不想显示特定的 错误栏,您必须在此命令中输入零值。 2003年, 您可以输入空字符串“”。在 Excel 2003 中,范围地址必须 以等号开头,=Sheet1!R2C7:R10C7; Excel 2007 接受 带或不带等号的地址。单个值或数组可以 在任一版本的 Excel 中输入时都可以带或不带等号。

Ozgrid 上的一篇文章中,Jon Peltier 说

自定义误差线值的范围不会暴露给 VBA

如果乔恩说做不到,那就做不到。


3
投票

我知道我迟到了 8 年……但我在网上搜索同一问题的答案时偶然发现了这一点。我也一无所获,所以我决定设计自己的解决方案,并认为我也可以将其发布,以防其他人最终来到这里。

它的工作原理是将工作簿 XML 提取到临时文件夹,在 XML 中找到错误栏引用,并将其作为 Range 对象返回。因此,您必须先保存对工作簿的更改,然后该功能才能发挥作用。如果更改误差条范围而不保存,该函数仍将返回最近保存的旧范围。它也不适用于 Excel 2003 或更早版本 (.xls) 的文件。

这一点也不优雅......但至少这在技术上是可能的!

使用方法:只需将下面的代码复制到标准模块中,然后调用

GetErrorBarRange(MySeries.ErrorBars, enErrorBarPlus)
获取正误差条的源范围,或
GetErrorBarRange(MySeries.ErrorBars, enErrorBarMinus)
获取负误差条的源范围(其中
MySeries.ErrorBars
是一些
 ErrorBars
对象)。传递可选的第三个参数
AutoSave:=True
将在查找错误栏源范围之前自动保存包含的工作簿。

' 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

0
投票

我刚刚测试了你的解决方案:

使用方法:只需将下面的代码复制到标准模块中,然后调用 GetErrorBarRange(MySeries.ErrorBars, enErrorBarPlus) 获取正误差条的源范围,或调用 GetErrorBarRange(MySeries.ErrorBars, enErrorBarMinus) 获取负误差条的源范围错误栏(其中 MySeries.ErrorBars 是某个 ErrorBars 对象)。传递可选的第三个参数 AutoSave:=True 将在查找错误栏源范围之前自动保存包含的工作簿。

并且它工作正常(至少在 Windows 上),感谢您提供它! 它肯定会简化我的代码之一,我会将您的名字附加到该函数中。

但是,如果有人打算使用它,下面我报告一些小错误和改进/解决方案:

  1. 如果您使用非英文Excel并使用自动图表名称,则可能与

    strChartName
    不兼容。
    strChartName = oChart.Parent.Name
    将以英语显示,但将以文件中的 Excel 语言设置编写。例如,对于法语 Excel,我在后面添加了
    strChartName = Replace(strChartName, "Chart", "Graphique")
    以使其正常工作。

  2. 如果你在系列名称中包含“é”字符(例如“séries 1”法语自动名称...),它将无法找到

    strSeriesName
    (我猜这是相同的语言问题)

  3. 如果

    ErrorBars
    在图表中不是作为 RANGE 输入,而是作为 ARRAY 输入,则
    xml
    结构不一样,需要调整代码。下面是我的解决方案,适用于范围和数组,并返回与
    ErrorBars
    值相对应的字符串表:

    ' Get the tab_points 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"
        ElseIf PlusMinus = enErrorBarPlus And (strErrBarType = "both" Or strErrBarType = "plus") Then
            strXPath = strXPath & "/c:plus"
        End If
        '=== add from A. Derycke
        ' handle the case of custom as a range or as an array
        If GetXPathFromXMLFile(strXMLFile, strXPath & "/c:numRef/c:f") <> "" Then 'range
            strXPath = strXPath & "/c:numRef/c:numCache"
            strXPath_bis = strXPath & "/c:ptCount/@val"
        Else 'array
            strXPath = strXPath & "/c:numLit"
            strXPath_bis = strXPath & "/c:ptCount/@val"
        End If
        ' retriver the number of point
        strNbPoint = GetXPathFromXMLFile(strXMLFile, strXPath_bis)
        ' boucle over every point and store them as string table
        ReDim tab_point(0 To Int(strNbPoint) - 1)
        'boucle over all points to get their values as string
        For i = 0 To Int(strNbPoint) - 1
            strXPath_tempo = strXPath & "/c:pt[@idx='" & i & "']/c:v"
            tab_point(i) = GetXPathFromXMLFile(strXMLFile, strXPath_tempo)
        Next i
    End If
    GetErrorBarRange = tab_point
    

要使用它,您只需替换原始代码的最后一部分并声明缺少的变量

strNbPoint
,
strXPath_tempo
,
strXPath_bis
,
i

© www.soinside.com 2019 - 2024. All rights reserved.