Why Experts Exchange?

Experts Exchange always has the answer, or at the least points me in the correct direction! It is like having another employee that is extremely experienced.

Jim Murphy
Programmer at Smart IT Solutions

When asked, what has been your best career decision?

Deciding to stick with EE.

Mohamed Asif
Technical Department Head

Being involved with EE helped me to grow personally and professionally.

Carl Webster
CTP, Sr Infrastructure Consultant
Ask ANY Question

Connect with Certified Experts to gain insight and support on specific technology challenges including:

Troubleshooting
Research
Professional Opinions
Ask a Question
Did You Know?

We've partnered with two important charities to provide clean water and computer science education to those who need it most. READ MORE

troubleshooting Question

Excel VBA: update graph through a function

Avatar of Luis Diaz
Luis Diaz asked on
Microsoft OfficeMicrosoft ExcelVBA
13 Comments1 Solution178 ViewsLast Modified:
Hello experts,

I have the following procedure which allows me to update graph referenced on attached file:
Option Explicit


Function PT_ScaleChartAxis(SheetName As String, ChartName As String, X_or_Y As Variant, Primary_or_Secondary As Variant, _
    Minimum As Variant, Maximum As Variant, MajorUnit As Variant, MinorUnit As Variant) As Variant
  
  Dim wks As Worksheet, cht As Chart, ax As Axis
  Dim xyAxisGroup As XlAxisGroup
  Dim rCaller As Range
  Dim dMinimum As Double, dMaximum As Double
  Dim bSetMin As Boolean, bSetMax As Boolean
  Dim sError As String, iError As Long
  Dim vTestCategory As Variant
  Dim srs As Series, rng As Range, lbl As DataLabel
  Dim iLbl As Long, nLbls As Long
  Dim sFmla As String, sTemp As String, vFmla As Variant

  Application.Volatile True
  
  If Len(SheetName) = 0 Then
    Set rCaller = Application.Caller ' cell containing UDF
    SheetName = rCaller.Parent.Name
  End If
  
  On Error Resume Next
  Set wks = Worksheets(SheetName)
  On Error GoTo 0
  If wks Is Nothing Then
    sError = "Worksheet '" & SheetName & "' not found"
'    GoTo ErrorFunction
  End If
  If wks.ChartObjects.Count = 0 Then
    sError = "No charts found on worksheet '" & SheetName & "'"
    GoTo ErrorFunction
  End If
  
  If Len(ChartName) = 0 Then
    ChartName = wks.ChartObjects(1).Name
  End If
  
  On Error Resume Next
  Set cht = wks.ChartObjects(ChartName).Chart
  On Error GoTo 0
  If cht Is Nothing Then
    sError = "Chart '" & ChartName & "' not found on worksheet '" & SheetName & "'"
    GoTo ErrorFunction
  End If
  
  Select Case LCase$(X_or_Y)
    Case "x", "1", "category", "cat"
      X_or_Y = xlCategory
      '' but not for non-value axes
    Case "y", "2", "value", "val"
      X_or_Y = xlValue
  End Select
  
  Select Case LCase$(Primary_or_Secondary)
    Case "primary", "pri", "1"
      Primary_or_Secondary = xlPrimary
    Case "secondary", "sec", "2"
      Primary_or_Secondary = xlSecondary
  End Select
  
  Set ax = cht.Axes(X_or_Y, Primary_or_Secondary)
  
  If ax.Type = xlCategory Then
    On Error Resume Next
    vTestCategory = ax.MinimumScale
    iError = Err.Number
    On Error GoTo 0
    If iError <> 0 Then
      sError = "Cannot scale a category-type axis"
      GoTo ErrorFunction
    End If
  End If
  
  If IsNumeric(Minimum) Or IsDate(Minimum) Then
    dMinimum = Minimum
    bSetMin = True
  Else
    Select Case LCase$(Minimum)
      Case "auto", "autoscale", "default"
        ax.MinimumScaleIsAuto = True
      Case "null", "skip", "ignore", "blank"
        ' make no change
      Case ""
        Minimum = "null"
        ' make no change
    End Select
  End If
  
  If IsNumeric(Maximum) Or IsDate(Maximum) Then
    dMaximum = Maximum
    bSetMax = True
  Else
    Select Case LCase$(Maximum)
      Case "auto", "autoscale", "default"
        ax.MaximumScaleIsAuto = True
      Case "null", "skip", "ignore", "blank"
        ' make no change
      Case ""
        Maximum = "null"
        ' make no change
    End Select
  End If
  
  If bSetMin And bSetMax Then
    If dMaximum <= dMinimum Then
      sError = "Maximum must be greater than Minimum"
      GoTo ErrorFunction
    End If
  End If
  
  If bSetMin Then
    ax.MinimumScale = dMinimum
  End If
  
  If bSetMax Then
    ax.MaximumScale = dMaximum
  End If
  
  If IsNumeric(MajorUnit) Then
    If MajorUnit > 0 Then
      ax.MajorUnit = MajorUnit
    End If
  Else
    Select Case LCase$(MajorUnit)
      Case "auto", "autoscale", "default"
        ax.MajorUnitIsAuto = True
      Case "null", "skip", "ignore", "blank"
        ' make no change
      Case ""
        MajorUnit = "null"
        ' make no change
    End Select
  End If
  
  If IsNumeric(MinorUnit) Then
    If MinorUnit > 0 Then
      ax.MinorUnit = MinorUnit
    End If
  Else
    Select Case LCase$(MinorUnit)
      Case "auto", "autoscale", "default"
        ax.MinorUnitIsAuto = True
      Case "null", "skip", "ignore", "blank"
        ' make no change
      Case ""
        MinorUnit = "null"
        ' make no change
    End Select
  End If
  
  'Add data labels
  Set srs = cht.SeriesCollection(1)
  If Not srs Is Nothing Then
      ' parse series formula to get range containing X values
      sFmla = srs.Formula
      sTemp = Mid$(Left$(sFmla, Len(sFmla) - 1), InStr(sFmla, "(") + 1)
      vFmla = Split(sTemp, ",")
      sTemp = vFmla(LBound(vFmla) + 1)
      'On Error Resume Next
      Set rng = Range(sTemp)

      If Not rng Is Nothing Then
        nLbls = srs.Points.Count
        If rng.Cells.Count < nLbls Then nLbls = rng.Cells.Count
        For iLbl = 1 To nLbls
          srs.Points(iLbl).HasDataLabel = True
          Set lbl = srs.Points(iLbl).DataLabel
          With lbl
          If MajorUnit < 1 Then
            .Text = rng.Offset(, 1).Cells(iLbl)
            '.Text = rng.Offset(, 1).Cells(iLbl) & ", " & Format(rng.Cells(iLbl), "hh:mm")
          Else
            .Text = rng.Offset(, 1).Cells(iLbl)
            '.Text = rng.Offset(, 1).Cells(iLbl) & ", " & rng.Cells(iLbl)
          End If
            .Position = xlLabelPositionLeft
          End With
        Next
      End If
    End If
  
  If MajorUnit < 1 Then
    PT_ScaleChartAxis = "Sheet '" & SheetName & "' Chart '" & ChartName & "' " _
        & Choose(Primary_or_Secondary, "Primary", "Secondary") & " " _
        & Choose(X_or_Y, "X", "Y") & " Axis " _
        & "{" & Minimum & ", " & Maximum & ", " & Format(MajorUnit, "hh:mm") & ", " & Format(MinorUnit, "hh:mm") & "}"
  Else
'    PT_ScaleChartAxis = "Sheet '" & SheetName & "' Chart '" & ChartName & "' " _
        & Choose(Primary_or_Secondary, "Primary", "Secondary") & " " _
        & Choose(X_or_Y, "X", "Y") & " Axis " _
        & "{" & Minimum & ", " & Maximum & ", " & MajorUnit & ", " & MinorUnit & "}"
  End If
ExitFunction:
  Exit Function
  
ErrorFunction:
  PT_ScaleChartAxis = sError
  GoTo ExitFunction
End Function
I have two issues:
1.I would like to move graph on 2.Graph sheet.
I don't know what is the best way to update:
Set cht = wks.ChartObjects(ChartName).Chart
which is referenced through:
wks = Worksheets(SheetName)
2.Add in the function the update of color data label based on source data which is currently updated through the following procedure:
Sub ApplyDataLables()

    Dim s As Series, dl As DataLabels, d As DataLabel
    Dim i As Long, rngLabels
    Dim LastRow  As Long
    
    Set s = ActiveSheet.ChartObjects(1).Chart.SeriesCollection(1)
    Set dl = s.DataLabels
    LastRow = ActiveSheet.Range("E" & Rows.Count).End(xlUp).Row
'
'    Option 1: set label color based on label value
'    For i = 1 To dl.Count
'        With dl(i)
'            .Font.Color = IIf(Val(.Text) < 0, vbRed, vbGreen)
'        End With
'    Next i


    'Option 2: set label color based on label source cell
     ' Note use of DisplayFormat to pick up custom
      ' formatting Colors
      
    Set rngLabels = Range("E45:E" & LastRow)
    For i = 1 To dl.Count
        dl(i).Font.Color = rngLabels(i).DisplayFormat.Font.Color
    Next i
End Sub
If you have questions, please contact me.
Thank you in advance for your help.
Timeline.xlsm
ASKER CERTIFIED SOLUTION
Avatar of Ejgil Hedegaard
Ejgil HedegaardFlag of Denmark image

Our community of experts have been thoroughly vetted for their expertise and industry experience.

Commented:
This problem has been solved!
Unlock 1 Answer and 13 Comments.
See Answers