Solved: Updating Charts in VBA with listbox

[f2e4]

Hey again,

I am trying to create a chart that automatically refreshes depending on a value selected from a listbox1.

Both listbox1 and chart are on sheet1

Listbox contains list of names from sheet "Fee Earning Stats"

In this sheet, beside each name is 6 columns of data

Is it possible to have the chart on sheet1 refresh each time I click a name in the listbox1.

The code would probably have to store the selected listbox value, search through the "Fee Earning Stats" sheet for that name and select the 6 columns beside that particular name.

Is this possible??

My VBA is starting to get better but charting in code is still a mystery.

Below is an example of code where I manually selected 6 columns of data for a name selected in the listbox

[vba]ActiveSheet.ChartObjects("Chart 77").Activate
ActiveChart.SeriesCollection(1).Select
ActiveChart.SeriesCollection(1).XValues = "='Fee Earning Stats'!R5C5:R5C10"
ActiveChart.SeriesCollection(1).Values = "='Fee Earning Stats'!R30C5:R30C10"
ActiveChart.SeriesCollection(2).XValues = "='Fee Earning Stats'!R5C5:R5C10"
ActiveChart.SeriesCollection(2).Values = "='Non Fee Earning Stats'!R30C5:R30C10"
ActiveWindow.Visible = False
Windows("Book1.xls").Activate[/vba]

[mdmackillop]

Posting a sample would avoid all participants having to replicate your data and controls.

[f2e4]

Posting a sample would avoid all participants having to replicate your data and controls.

Further information and steps needed are written in the first sheet (see attached)

Thanks for helping out

[mdmackillop]

[vba]
Option Explicit
Private Sub ListBox1_Change()
Dim tmp As Long, Rw As Long
Dim StaffMember As String, ChrtRng As String
'Get name
tmp = ListBox1.ListIndex
With ListBox1
StaffMember = .List(tmp, 1) & " " & .List(tmp, 0)
End With
'Find Row
On Error Resume Next
Rw = Sheets("Fee Earning Stats").Columns(2).Find(StaffMember).Row
If Rw = 0 Then
MsgBox "Name not found"
Exit Sub
End If

'Create text string for range
ChrtRng = "$E$" & Rw & ":$J" & Rw

'Modify data range
ActiveSheet.ChartObjects("Chart 77").Select
ActiveChart.SeriesCollection(2).Formula = _
"=SERIES(""Non Fee Earning"",'Fee Earning Stats'!$E$5:$J$5,'Non Fee Earning Stats'!" & ChrtRng & ",2)"
ActiveChart.SeriesCollection(1).Formula = _
"=SERIES(""Fee Earning"",'Fee Earning Stats'!$E$5:$J$5,'Fee Earning Stats'!" & ChrtRng & ",1)"

'Return focus to ListBox
ListBox1.Activate


End Sub

[/vba]

[f2e4]

Hey mdmackillop,

Thanks very much for helping with this. It seems to be working perfectly.

Do you know how I can actually highlight the value in the listbox.

At the minute, using the code above, when i select a listbox value, the code runs fine and updates the chart, but the listbox value does not highlight making it a bit difficult to see which one I pressed.

Thanks again,

F

[Bob Phillips]

What do you mean? I tried it and the selected item stayed selected, and thus highighted.

[f2e4]

Weird!!!

I have fixed it now.

When i pasted the code back into my original spreadsheet, I forgot to delete the Application.ScreenUpdating lines.

Works fine now.


Xld, would you have any idea how to resolve my date issue? (see description in sheet attached above)

At present, the 6 columns of data selected are set, but i was wondering if it is possible for this range to move forward 1 column on a weekly basis

[Bob Phillips]

[vba]

Option Explicit

Private Sub ListBox1_Change()
Dim tmp As Long, Rw As Long
Dim StaffMember As String, ChrtRng As String
Dim StartDate As Date
Dim StartCol As Long
Dim StartLetter As String
Dim EndLetter As String

StartDate = Date + 6 - Weekday(Date)
StartCol = Application.Match(CLng(StartDate), Worksheets("Non Fee Earning Stats").Rows(5), 0)
StartLetter = ColumnLetter(StartCol)
If StartCol >= 30 Then

EndLetter = ColumnLetter(35)
Else

EndLetter = ColumnLetter(StartCol + 5)
End If

'Get name
tmp = ListBox1.ListIndex
With ListBox1
StaffMember = .List(tmp, 1) & " " & .List(tmp, 0)
End With
'Find Row
On Error Resume Next
Rw = Sheets("Fee Earning Stats").Columns(2).Find(StaffMember).Row
If Rw = 0 Then
MsgBox "Name not found"
Exit Sub
End If

'Create text string for range
ChrtRng = "$" & StartLetter & "$" & Rw & ":$" & EndLetter & "$" & Rw

'Modify data range
ActiveSheet.ChartObjects("Chart 77").Select
ActiveChart.SeriesCollection(2).Formula = _
"=SERIES(""Non Fee Earning"",'Fee Earning Stats'!$" & StartLetter & "$5:$" & EndLetter & "$5,'Non Fee Earning Stats'!" & ChrtRng & ",2)"
ActiveChart.SeriesCollection(1).Formula = _
"=SERIES(""Fee Earning"",'Fee Earning Stats'!$" & StartLetter & "$5:$" & EndLetter & "$5,'Fee Earning Stats'!" & ChrtRng & ",1)"

'Return focus to ListBox
ListBox1.Activate
End Sub

'-----------------------------------------------------------------
Function ColumnLetter(Col As Long)
'-----------------------------------------------------------------
Dim sColumn As String
On Error Resume Next
sColumn = Split(Columns(Col).Address(, False), ":")(1)
On Error GoTo 0
ColumnLetter = sColumn
End Function
[/vba]

but I would add a slider so that they can slide forward, or back.

[f2e4]

Thanks a lot for that - its really appreciated.

I suppose it would be asking a bit much of you to teach me how to do the slider bit??

[Bob Phillips]

Your workbook keeps crashing my Excel, laptop and desktop, but I finally got one working, so I hope it is stable for you.

[f2e4]

Sorry about the grief its giving you, but if I could return the favour, I would.

I was having problems running the code for calculating all the data in the Fee Earning Sheet while the listbox code was active - but i posted this problem in a new post.

[Bob Phillips]

I can't upload it either, it just freezes.

[f2e4]

I PM'ed you my email address if you still can't get it to upload

[f2e4]

Hey,

I tried out your slider code, but just like you, it keeps crashing excel everytime i change a value or page.

Thanks for all the help, but i'll probably go with your code above, seeing as other people will have to use this sheet as well.

[Bob Phillips]

Shame, but just for interest, here is an example of the technique.

I have adapted this approach for a Gantt chart I run in Excel. It is quite neat.

[f2e4]

Yeah that scrolling bar would have been great to have included in my sheet. No idea why it was crashing everytime.

But thanks for all the help getting to where it is now

[mdmackillop]

I tried a scroll row and this gets it working after a fashion. A few bugss need to be sorted though.
[vba]
Private Sub ListBox1_Change()
Dim tmp As Long, Rw As Long, DteRng As String
Dim StaffMember As String, ChrtRng As String
'Get name
tmp = ListBox1.ListIndex
With ListBox1
StaffMember = .List(tmp, 1) & " " & .List(tmp, 0)
End With
'Find Row
On Error Resume Next
Rw = Sheets("Fee Earning Stats").Columns(2).Find(StaffMember).Row
If Rw = 0 Then
MsgBox "Name not found"
Exit Sub
End If

tmp = ScrollBar1.Value
'Create text string for range
DteRng = Cells(5 + tmp, 5).Address & ":" & Cells(10 + tmp, 5).Address
ChrtRng = Cells(5 + tmp, Rw).Address & ":" & Cells(10 + tmp, Rw).Address

'Modify data range
ActiveSheet.ChartObjects("Chart 77").Select
ActiveChart.SeriesCollection(2).Formula = "=SERIES(""Non Fee Earning"",'Fee Earning Stats'!" & _
DteRng & ",'Non Fee Earning Stats'!" & ChrtRng & ",2)"
ActiveChart.SeriesCollection(1).Formula = _
"=SERIES(""Fee Earning"",'Fee Earning Stats'!" & DteRng & ",'Fee Earning Stats'!" & _
ChrtRng & ",1)"


End Sub
Private Sub ScrollBar1_Change()
Dim tmp As Long, Rw As Long, DteRng As String
Dim StaffMember As String, ChrtRng As String
'Get name
tmp = ListBox1.ListIndex
With ListBox1
StaffMember = .List(tmp, 1) & " " & .List(tmp, 0)
End With
'Find Row
On Error Resume Next
Rw = Sheets("Fee Earning Stats").Columns(2).Find(StaffMember).Row
tmp = ScrollBar1.Value
'Create text string for range
DteRng = Cells(5 + tmp, 5).Address & ":" & Cells(10 + tmp, 5).Address
ChrtRng = Cells(5 + tmp, Rw).Address & ":" & Cells(10 + tmp, Rw).Address

'Modify data range
ActiveSheet.ChartObjects("Chart 77").Select
ActiveChart.SeriesCollection(2).Formula = "=SERIES(""Non Fee Earning"",'Fee Earning Stats'!" & _
DteRng & ",'Non Fee Earning Stats'!" & ChrtRng & ",2)"
ActiveChart.SeriesCollection(1).Formula = _
"=SERIES(""Fee Earning"",'Fee Earning Stats'!" & DteRng & ",'Fee Earning Stats'!" & ChrtRng & ",1)"
End Sub
[/vba]

[f2e4]

OK,

So i started playing round with mdmackillop's code and have come up with, what seems to be, very stable code.....touch wood.

I created a Forms scroll bar and linked that to a hidden cell on my page - rather than creating code to use under scrolbar1_change()

This is what I came up with:

[vba]Sub ListBox1_Change()
If RunList = True Then
Dim tmp As Long, Rw As Long, scrl As Long
Dim StaffMember As String, ChrtRng As String, Chrt2Rng As String
Dim StartDate As Date
Dim StartCol As Long
Dim StartLetter As String
Dim EndLetter As String

'Hidden Linked Cell
scrl = Sheets("Reports").Range("L17").Value

'Change week ending dates
If scrl = 0 Then
StartDate = Date + 6 - Weekday(Date)
Else
StartDate = Date + 6 - Weekday(Date) + (scrl * 7)
End If

StartCol = Application.Match(CLng(StartDate), Worksheets("Fee Earning Stats").Rows(5), 0)
StartLetter = ColumnLetter(StartCol)
If StartCol >= 30 Then
EndLetter = ColumnLetter(35)
Else
EndLetter = ColumnLetter(StartCol + 5)
End If
tmp = ListBox1.ListIndex
With ListBox1
StaffMember = .List(tmp, 1) & " " & .List(tmp, 0)
End With
On Error Resume Next
Rw = Sheets("Fee Earning Stats").Columns(2).Find(StaffMember).Row
If Rw = 0 Then
MsgBox "Staff member has no current data"
Exit Sub
End If
ChrtRng = "$" & StartLetter & "$" & Rw & ":$" & EndLetter & "$" & Rw
ActiveSheet.ChartObjects("Chart 77").Select
ActiveChart.SeriesCollection(2).Formula = _
"=SERIES(""Non Fee Earning"",'Fee Earning Stats'!$" & StartLetter & "$5:$" & EndLetter & _
"$5,'Non Fee Earning Stats'!" & ChrtRng & ",2)"
ActiveChart.SeriesCollection(1).Formula = _
"=SERIES(""Fee Earning"",'Fee Earning Stats'!$" & StartLetter & "$5:$" & EndLetter & _
"$5,'Fee Earning Stats'!" & ChrtRng & ",1)"
End If
ListBox1.Activate
End Sub[/vba]

[Bob Phillips]

Post the working workbook.

[f2e4]

This is an example of my scrolling bar using the code above

See attached file