• Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 152
  • Last Modified:

Dynamic Ranges for Charts

Good Afternoon,

I am trying to set up dynamic ranges for my charts.  I have attached an example of the spreadsheet.  The chart should only show the information for the department and month selected.  For example, March only has 9 days updated, so the chart should only show the first 9 days.

Thanks in advanced,
Joan
DailyRev2014.xlsx
0
jmkbrown
Asked:
jmkbrown
  • 5
  • 2
1 Solution
 
gowflowCommented:
Is this what you want ?? This sub will adjust the Graph's serie to match the last row of data in sheet Daily Col L to S

I created a button on the Dashboard that you can activate it will adjust the data to match for that graph.

Sub AdjustChartDataRange()
Dim oChrt As ChartObject
Dim Chrt As Chart
Dim sSerie As Series
Dim WS As Worksheet
Dim WSDaily As Worksheet
Dim MaxRow As Long, I As Long
Dim Frmla As String, fmRow As String, toRow As String
Dim SplitFrmla

Set WS = ActiveSheet
Set WSDaily = Sheets("Daily")

Do
    MaxRow = MaxRow + 1
Loop Until WSDaily.Cells(MaxRow, "L") = ""
If MaxRow > 1 Then MaxRow = MaxRow - 1

For Each oChrt In WS.ChartObjects
    If oChrt.Name = "Chart 1" Then
        Set Chrt = oChrt.Chart
        
        For Each sSerie In Chrt.SeriesCollection
            Frmla = sSerie.Formula
            SplitFrmla = Split(Frmla, ",")
            For I = LBound(SplitFrmla) To UBound(SplitFrmla)
                If InStr(1, SplitFrmla(I), ":") <> 0 Then
                    '---> Get the ToRow
                    toRow = Mid(SplitFrmla(I), InStrRev(SplitFrmla(I), "$") + 1, Len(SplitFrmla(I)) - InStrRev(SplitFrmla(I), "$"))
                    SplitFrmla(I) = Replace(SplitFrmla(I), toRow, Format(MaxRow, "@"))
                End If
            
            Next I
            
            Frmla = ""
            For I = LBound(SplitFrmla) To UBound(SplitFrmla)
                If Frmla <> "" Then Frmla = Frmla & ","
                Frmla = Frmla & SplitFrmla(I)
            Next I
            
            '---> Affect  New Formula
            sSerie.Formula = Frmla
        Next sSerie
    
    End If
Next oChrt
End Sub

Open in new window


Let me know
gowflow
DailyRev2014.xlsm
0
 
jmkbrownAuthor Commented:
I would like for this to work any time the user changes the value in cell E1 and I only want it to change "Chart 1".  The other charts I will be adding to the spreadsheet will be based on other data, therefore I only want chart 1 to change.

Thanks!
0
 
gowflowCommented:
ok I must hv messed up your data for the second chart, Sorry !!!
Here it is now will only do that for Chart1 (although the previous version was only doing it for Chart1) don't really know why data disappeared for Chart2. and it will work when you select a department. I removed the button.

gowflow
DailyRev2014-V01.xlsm
0
Free Tool: Site Down Detector

Helpful to verify reports of your own downtime, or to double check a downed website you are trying to access.

One of a set of tools we are providing to everyone as a way of saying thank you for being a part of the community.

 
gowflowCommented:
OOOPSSSS !!!!

You said E1 !!!

I had never realized there was an E1 at the first place that list the months and that could be changed !!!

Pls do not consider the previous version let me revise the whole thing will get back to you.

Sorry again but your dropdown are too much 'cramped' with the heading and can be hardly seen !!! (at least for someone who did not design them)

Will revert
gowflow
0
 
gowflowCommented:
Well I have to admit it was not an easy one !!! as your data when filtered (when you flip between month or departments ..) it does leave blanks rows that are blank between header and real data which was causing all this mess.

I was able to fix all this and here is the code that get triggered either if you change a department or when you change a month. For sure when you select a month that has no data like Apr and up then the graph is blank which is normal.

I do not know what was the ranges affected to the second graph I made sure the below code will only affect the first Chart1.

Please check the attached file and let me know your comments.

here is the code for your convenience.

Sub AdjustChartDataRange()
Dim oChrt As ChartObject
Dim Chrt As Chart
Dim sSerie As series
Dim WS As Worksheet
Dim WSDaily As Worksheet
Dim MaxRow As Long, MinRow As Long, I As Long
Dim Frmla As String, fmRow As String, toRow As String
Dim SplitFrmla
Dim DataRange As Range

Set WS = ActiveSheet
Set WSDaily = Sheets("Daily")
'MsgBox ("X")
MinRow = 0
MaxRow = 0

For I = 2 To WSDaily.Range("L" & WSDaily.Rows.Count).End(xlUp).Row
    If WSDaily.Cells(I, "L").Value <> "" And MinRow = 0 Then
        MinRow = I
        MaxRow = I
    End If
    
    If WSDaily.Cells(I, "L").Value <> "" And I > MaxRow Then
        MaxRow = I
    End If
    
Next I

If MinRow = 0 Or MaxRow = 0 Then Exit Sub

For Each oChrt In WS.ChartObjects
    If oChrt.Name = "Chart 1" Then
        Set Chrt = oChrt.Chart
        
        For Each sSerie In Chrt.SeriesCollection
            
            Frmla = sSerie.Formula
            SplitFrmla = Split(Frmla, ",")
            For I = LBound(SplitFrmla) To UBound(SplitFrmla)
                
                If I = LBound(SplitFrmla) Then
                    '---> On first Item Make sure Row is always 1
                    '---> Get the fmRow
                    fmRow = Mid(SplitFrmla(I), InStrRev(SplitFrmla(I), "$") + 1, Len(SplitFrmla(I)) - InStrRev(SplitFrmla(I), "$"))
                    SplitFrmla(I) = Replace(SplitFrmla(I), fmRow, Format(1, "@"), , 1)

                    
                ElseIf InStr(1, SplitFrmla(I), ":") = 0 And InStr(1, SplitFrmla(I), "$") <> 0 Then
                    '---> If $ exist but not : then Change fmRow
                    '---> Get the fmRow
                    fmRow = Mid(SplitFrmla(I), InStrRev(SplitFrmla(I), "$") + 1, Len(SplitFrmla(I)) - InStrRev(SplitFrmla(I), "$"))
                    SplitFrmla(I) = Replace(SplitFrmla(I), fmRow, Format(MinRow, "@"), , 1)
                
                ElseIf InStr(1, SplitFrmla(I), ":") <> 0 And InStr(1, SplitFrmla(I), "$") <> 0 Then
                    '---> If $ exist and : exist change both fmRow and toRow
                    '---> Get the ToRow
                    toRow = Mid(SplitFrmla(I), InStrRev(SplitFrmla(I), "$") + 1, Len(SplitFrmla(I)) - InStrRev(SplitFrmla(I), "$"))
                    SplitFrmla(I) = Replace(SplitFrmla(I), toRow, Format(MaxRow, "@"), , 1)
                    
                    '---> Get the fmRow
                    fmRow = Mid(SplitFrmla(I), InStrRev(SplitFrmla(I), "$", InStrRev(SplitFrmla(I), ":")) + 1, InStrRev(SplitFrmla(I), ":") - InStrRev(SplitFrmla(I), "$", InStrRev(SplitFrmla(I), ":")) - 1)
                    SplitFrmla(I) = Replace(SplitFrmla(I), fmRow, Format(MinRow, "@"), , 1)
                
                ElseIf I = 1 And SplitFrmla(I) = "" Then
                    '---> Force Creation of the Formula
                    SplitFrmla(I) = "Daily!$M$" & Format(MinRow, "@") & ":$M$" & Format(MaxRow, "@")
                
                End If
            
            Next I
            
            Frmla = ""
            For I = LBound(SplitFrmla) To UBound(SplitFrmla)
                If Frmla <> "" Then Frmla = Frmla & ","
                Frmla = Frmla & SplitFrmla(I)
            Next I
            
            '---> Affect  New Formula
            sSerie.Formula = Frmla
        Next sSerie
        
        Exit For
    End If
    
Next oChrt
End Sub



Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("B1")) Is Nothing Or Not Intersect(Target, Range("E1")) Is Nothing Then
    AdjustChartDataRange
End If
End Sub

Open in new window


PS I highlighted both Department and Month to make it clear ! if you don't like it no problem it can be removed safely.
Gowflow
DailyRev2014-V02.xlsm
0
 
jmkbrownAuthor Commented:
This works great!  Thank you very much!
0
 
gowflowCommented:
Your welcome glad I could help.
gowflow
0

Featured Post

Receive 1:1 tech help

Solve your biggest tech problems alongside global tech experts with 1:1 help.

  • 5
  • 2
Tackle projects and never again get stuck behind a technical roadblock.
Join Now