You are here:

Excel/Bubble chart for non-contigous range

Question
Hi Tom!

the question may seem long but it isn't; is is just my current code.
Currently I am trying create a bubble chart from a range selected by the user. To do this I am plotting a new series for every data point, because I need to have the bubbles labeled. This range may not be contigious. For instance (See Graph 1), the user selected the cells that are in green (4 noncontigious series: A, C, E, F), but if you see the Graph picture, it plotted the first four (A,B,C,D). How do I make it plot the right selected ranges?
The code is below.

Public Sub BubbleChart()
Dim BubbleChart As ChartObject, c As Long
Dim NumberofColumns As Long
Dim UserRange As Range
Dim SelectionLength As Double
Dim rangeScore As Range
Dim ScoreMax As Double
Dim ScoreMin As Double
Dim rangeProbability As Range
Dim ProbabilityMax As Double
Dim ProbabilityMin As Double

Worksheets("Scoring USP").Activate

With Worksheets("Scoring USP")
NumberofColumns = .Cells(3, .Columns.Count).End(xlToLeft).Column
NumberRewardScore = .Cells(19, .Columns.Count).End(xlToLeft).Column
NumberProbability = .Cells(20, .Columns.Count).End(xlToLeft).Column
NumberTotal = .Cells(24, .Columns.Count).End(xlToLeft).Column
End With

d = NumberofColumns - 8  ' Number of columns with data in them

''''''''' Making sure everything has the same dimensions
'If NumberofColumns > NumberRewardScore Then
'  MsgBox "One or more projects are missing their 'Reward Score'!"
'  'Exit Sub
'ElseIf NumberofColumns < NumberRewardScore Then
'  MsgBox "There are more reward scores than projects!"
'  'Exit Sub

'End If

'If NumberofColumns > NumberProbability Then
'  MsgBox "One or more projects are missing their 'Probability'!"
'  'Exit Sub
'ElseIf NumberofColumns < NumberProbability Then
'  MsgBox "There are more probability entries than projects!"
' ' Exit Sub

'End If

'If NumberofColumns > NumberTotal Then
'  MsgBox "One or more projects are missing their 'Total R&D Resources'!"
'Exit Sub
'ElseIf NumberofColumns < NumberTotal Then
'  MsgBox "There are more 'Total R&D Resources' entries than projects!"
'Exit Sub

'End If

'''''''''' Copying and pasting data to sheet

Worksheets("Scoring USP").Range(Cells(1, 8), Cells(1, NumberofColumns)).Copy
Worksheets("USP - Chart").Range("A7").PasteSpecial Paste:=xlPasteAllExceptBorders, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

Worksheets("Scoring USP").Range(Cells(3, 9), Cells(3, NumberofColumns)).Copy
Worksheets("USP - Chart").Range("B8").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

Worksheets("Scoring USP").Range(Cells(19, 8), Cells(19, NumberofColumns)).Copy
Worksheets("USP - Chart").Range("A9").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

Worksheets("Scoring USP").Range(Cells(20, 8), Cells(20, NumberofColumns)).Copy
Worksheets("USP - Chart").Range("A10").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

Worksheets("Scoring USP").Range(Cells(24, 8), Cells(24, NumberofColumns)).Copy
Worksheets("USP - Chart").Range("A11").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

Worksheets("USP - Chart").Activate

Worksheets("USP - Chart").Rows("7").RowHeight = 61.2
Worksheets("USP - Chart").Rows("8").RowHeight = 61.2
Worksheets("USP - Chart").Rows("9:11").RowHeight = 30
Worksheets("USP - Chart").Columns("A").ColumnWidth = 40
Worksheets("USP - Chart").Range(Cells(1, 2), Cells(1, NumberofColumns - 7)).ColumnWidth = 30
Worksheets("USP - Chart").Range(Cells(7, 1), Cells(11, NumberofColumns - 7)).Interior.Color = RGB(255, 255, 255)
Worksheets("USP - Chart").Range(Cells(7, 1), Cells(11, NumberofColumns - 7)).Font.Bold = True
Worksheets("USP - Chart").Range(Cells(7, 1), Cells(11, NumberofColumns - 7)).Font.Size = 16
Worksheets("USP - Chart").Range(Cells(7, 1), Cells(11, NumberofColumns - 7)).Font.Name = "Calibri"
Worksheets("USP - Chart").Range(Cells(7, 1), Cells(11, NumberofColumns - 7)).Font.Color = RGB(0, 0, 0)
Worksheets("USP - Chart").Range(Cells(7, 1), Cells(11, NumberofColumns - 7)).HorizontalAlignment = xlCenter
Worksheets("USP - Chart").Range(Cells(7, 1), Cells(11, NumberofColumns - 7)).VerticalAlignment = xlCenter
Worksheets("USP - Chart").Range(Cells(7, 1), Cells(11, 1)).HorizontalAlignment = xlLeft
Worksheets("USP - Chart").Rows("8").WrapText = True
Worksheets("USP - Chart").Range(Cells(7, 1), Cells(7, NumberofColumns - 7)).Font.Size = 48
Worksheets("USP - Chart").Range(Cells(7, 1), Cells(7, NumberofColumns - 7)).Font.Bold = False
Worksheets("USP - Chart").Range(Cells(9, 2), Cells(11, NumberofColumns - 7)).Font.Bold = False
Worksheets("USP - Chart").Range(Cells(7, 1), Cells(11, NumberofColumns - 7)).Borders.LineStyle = xlContinuous
Worksheets("USP - Chart").Range(Cells(7, 1), Cells(11, NumberofColumns - 7)).Borders.Color = vbBlack
Worksheets("USP - Chart").Range(Cells(7, 1), Cells(11, NumberofColumns - 7)).Borders.Weight = xlThin

''''''''''' Select Range
Set UserRange = Nothing
On Error Resume Next
Set UserRange = Application.InputBox(Prompt:="Please Select Range. It must include the OR Name, Reward, Probability, and Resources!", Title:="Range Select", Type:=8)
On Error GoTo 0
If UserRange Is Nothing Then Exit Sub
UserRange.Select

While Selection.Rows.Count <> 4
If (Selection.Rows.Count <> 4 Or Selection.Columns.Count < 1) Then
MsgBox "Please select your data. Selection must have 4 rows, and at least 1 coloumn. It must include the OR Name, Reward, Probability, and Resources!"
Set UserRange = Nothing
On Error Resume Next
Set UserRange = Application.InputBox(Prompt:="Please Select Range. It must include the OR Name, Reward, Probability, and Resources!", Title:="Range Select", Type:=8)
On Error GoTo 0
If UserRange Is Nothing Then Exit Sub
UserRange.Select
End If
Wend
Selection.Interior.Color = RGB(146, 208, 80)
SelectionLength = Intersect(UserRange, UserRange(1, 1).EntireRow).Cells.Count

'Set ChartData = Application.Union(UserRange)
'MsgBox ChartData
'ChartData.Select

''''''''' Find Max and Min values for smart dimensioning

'''' Score Max and Min
Set rangeScore = Range(Selection.Cells(2, 1), Selection.Cells(2, SelectionLength))
ScoreMax = Application.Max(rangeScore)
ScoreMin = Application.Min(rangeScore)

'''' Probabiblity Max and Min

Set rangeProbability = Range(Selection.Cells(3, 1), Selection.Cells(3, SelectionLength))
ProbabilityMax = Application.Max(rangeProbability)
ProbabilityMin = Application.Min(rangeProbability)

'''''''''' Center of Dashed Lines

'Worksheets("USP - Chart").Activate

Dim r As Range
Set r = Worksheets("USP - Chart").Range("H3:H4")
For Each Cell In r
If IsEmpty(Cell) Then
l = (ScoreMax + ScoreMin) / 2
w = (ProbabilityMax + ProbabilityMin) / 2

Else
l = Worksheets("USP - Chart").Range("H3").Value
w = Worksheets("USP - Chart").Range("H4").Value

End If
Next

For Each BubbleChart In ActiveSheet.ChartObjects
BubbleChart.Delete
Next BubbleChart

Set BubbleChart = Worksheets("USP - Chart").ChartObjects.Add(Left:=50, Width:=1200, Top:=360, Height:=800)
BubbleChart.Chart.ChartType = xlBubble

''''''' Vertical and Horizontal Lines
With BubbleChart.Chart.SeriesCollection.NewSeries
.Name = "Invisible1"
.XValues = l
.Values = w
.BubbleSizes = 0.1
End With

With BubbleChart.Chart.SeriesCollection.NewSeries
.Name = "Invisible2"
.XValues = l
.Values = w
.BubbleSizes = 0.1
End With

Dim ser As Series

Set ser = BubbleChart.Chart.SeriesCollection(1)
ser.ErrorBar Direction:=xlX, _
Include:=xlErrorBarIncludeBoth, _
Type:=xlErrorBarTypeFixedValue, _
Amount:=ScoreMax * 100
ser.ErrorBars.Format.Line.ForeColor.RGB = RGB(7, 114, 255)
ser.ErrorBars.Format.Line.Weight = 5
ser.ErrorBars.Format.Line.DashStyle = msoLineSysDash

Set ser2 = BubbleChart.Chart.SeriesCollection(2)
ser2.ErrorBar Direction:=xlY, _
Include:=xlErrorBarIncludeBoth, _
Type:=xlErrorBarTypeFixedValue, _
Amount:=ProbabilityMax * 100
ser2.ErrorBars.Format.Line.ForeColor.RGB = RGB(7, 114, 255)
ser2.ErrorBars.Format.Line.Weight = 5
ser2.ErrorBars.Format.Line.DashStyle = msoLineSysDash
''''' Plot the rest of the Series
For c = 1 To SelectionLength

With BubbleChart.Chart.SeriesCollection.NewSeries
Words = Selection.Cells(1, c)
Words = Trim(Left(Application.WorksheetFunction.Substitute(Words, " ", Application.WorksheetFunction.Rept(" ", 100)), 300))
.Name = Words

End With

Next
' For c = 9 To NumberofColumns
'With BubbleChart.Chart.SeriesCollection.NewSeries

'.Name = "=" & Worksheets("Scoring USP").Cells(3, c).Address(External:=True)
' .XValues = "=" & Worksheets("Scoring USP").Cells(19, c).Address(External:=True)
' .Values = "=" & Worksheets("Scoring USP").Cells(20, c).Address(External:=True)
' .BubbleSizes = "=" & Worksheets("Scoring USP").Cells(24, c).Address(External:=True)
'  End With

' Next

''''' Formatting of Chart

BubbleChart.Chart.Axes(xlCategory, xlPrimary).AxisTitle.Text = "Rewards"

BubbleChart.Chart.SetElement (msoElementPrimaryValueAxisTitleRotated)
BubbleChart.Chart.Axes(xlValue, xlPrimary).AxisTitle.Text = "Probability of Success"

BubbleChart.Chart.SetElement (msoElementPrimaryCategoryGridLinesMajor)
BubbleChart.Chart.Axes(xlCategory).MinimumScale = 2
If SelectionLength > 1 Then
BubbleChart.Chart.Axes(xlCategory).Select
BubbleChart.Chart.Axes(xlCategory).MinimumScale = ScoreMin - ((ScoreMax - ScoreMin) / 5)
BubbleChart.Chart.Axes(xlCategory).MaximumScale = ScoreMax + ((ScoreMax - ScoreMin) / 5)
BubbleChart.Chart.Axes(xlValue).Select
BubbleChart.Chart.Axes(xlValue).MinimumScale = ProbabilityMin - ((ProbabilityMax - ProbabilityMin) / 5)
BubbleChart.Chart.Axes(xlValue).MaximumScale = ProbabilityMax + ((ProbabilityMax - ProbabilityMin) / 5)
BubbleChart.Chart.ChartGroups(1).BubbleScale = 40
Else
BubbleChart.Chart.Axes(xlCategory).Select
BubbleChart.Chart.Axes(xlCategory).MinimumScale = ScoreMin / 2
BubbleChart.Chart.Axes(xlCategory).MaximumScale = ScoreMax * 1.5
BubbleChart.Chart.Axes(xlValue).Select
BubbleChart.Chart.Axes(xlValue).MinimumScale = ProbabilityMin / 2
BubbleChart.Chart.Axes(xlValue).MaximumScale = ProbabilityMax * 1.5
BubbleChart.Chart.ChartGroups(1).BubbleScale = 40

End If

BubbleChart.Chart.SetElement (msoElementChartTitleAboveChart)
BubbleChart.Chart.ChartTitle.Text = "CVT OR portfolio"
Selection.Format.TextFrame2.TextRange.Characters.Text = "CVT OR Portfolio"
With Selection.Format.TextFrame2.TextRange.Characters(1, 16).ParagraphFormat
.TextDirection = msoTextDirectionLeftToRight
.Alignment = msoAlignCenter
End With
With Selection.Format.TextFrame2.TextRange.Characters(1, 16).Font
.BaselineOffset = 0
.Bold = msoTrue
.NameComplexScript = "+mn-cs"
.NameFarEast = "+mn-ea"
.Fill.Visible = msoTrue
.Fill.ForeColor.RGB = RGB(0, 0, 0)
.Fill.Transparency = 0
.Fill.Solid
.Size = 35
.Italic = msoFalse
.Kerning = 12
.Name = "+mn-lt"
.UnderlineStyle = msoNoUnderline
.Strike = msoNoStrike
End With

For Counter = 3 To (SelectionLength + 2)
BubbleChart.Chart.SeriesCollection(Counter).Points(1).Select
BubbleChart.Chart.SeriesCollection(Counter).Points(1).ApplyDataLabels
BubbleChart.Chart.SeriesCollection(Counter).DataLabels.Select
Selection.ShowSeriesName = True
Selection.ShowValue = False
Selection.Format.TextFrame2.TextRange.Font.Size = 15
Selection.Format.TextFrame2.TextRange.Font.Bold = msoTrue

Next Counter

'''''' Bubbles' Colors
If Worksheets("USP - Chart").Range("J3").Value <> "y" And Worksheets("USP - Chart").Range("J3").Value <> "Y" And Worksheets("USP - Chart").Range("J3").Value <> "Yes" And Worksheets("USP - Chart").Range("J3").Value <> "yes" And Worksheets("USP - Chart").Range("J3").Value <> "Y" Then

For e = 1 To 2
BubbleChart.Chart.SeriesCollection(e).Points(1).Select
With Selection.Format.Fill
.Visible = msoTrue
.ForeColor.RGB = RGB(153, 204, 0)
.Transparency = 1
.Solid
End With
Next e

For e = 3 To (SelectionLength + 2)
BubbleChart.Chart.SeriesCollection(e).Points(1).Select
With Selection.Format.Fill
.Visible = msoTrue
.ForeColor.RGB = RGB(153, 204, 0)
.Transparency = 0
.Solid
End With
Next e
End If
''''''' Corner Labels
BubbleChart.Chart.Shapes.AddTextbox(msoTextOrientationHorizontal, 63, 77, 138, 60). _
Select
Selection.ShapeRange(1).TextFrame2.TextRange.Characters.Text = _
Selection.ShapeRange(1).TextFrame2.TextRange.Characters(1, 16).ParagraphFormat. _
FirstLineIndent = 0
Selection.ShapeRange.TextFrame2.TextRange.Font.Bold = msoTrue
Selection.ShapeRange.TextFrame2.TextRange.Font.Size = 20
Selection.ShapeRange.TextFrame2.TextRange.Font.Italic = msoTrue

BubbleChart.Chart.Shapes.AddTextbox(msoTextOrientationHorizontal, 1100, 77, 80, 30). _
Select
Selection.ShapeRange(1).TextFrame2.TextRange.Characters.Text = _
"Pearl"
Selection.ShapeRange(1).TextFrame2.TextRange.Characters(1, 5).ParagraphFormat. _
FirstLineIndent = 0
Selection.ShapeRange.TextFrame2.TextRange.Font.Bold = msoTrue
Selection.ShapeRange.TextFrame2.TextRange.Font.Size = 20
Selection.ShapeRange.TextFrame2.TextRange.Font.Italic = msoTrue

BubbleChart.Chart.Shapes.AddTextbox(msoTextOrientationHorizontal, 1100, 670, 80, 30). _
Select
Selection.ShapeRange(1).TextFrame2.TextRange.Characters.Text = _
"Oyster"
Selection.ShapeRange(1).TextFrame2.TextRange.Characters(1, 6).ParagraphFormat. _
FirstLineIndent = 0
Selection.ShapeRange.TextFrame2.TextRange.Font.Bold = msoTrue
Selection.ShapeRange.TextFrame2.TextRange.Font.Size = 20
Selection.ShapeRange.TextFrame2.TextRange.Font.Italic = msoTrue

BubbleChart.Chart.Shapes.AddTextbox(msoTextOrientationHorizontal, 63, 660, 140, 60). _
Select
Selection.ShapeRange(1).TextFrame2.TextRange.Characters.Text = _
"White Elephant"
Selection.ShapeRange(1).TextFrame2.TextRange.Characters(1, 14).ParagraphFormat. _
FirstLineIndent = 0
Selection.ShapeRange.TextFrame2.TextRange.Font.Bold = msoTrue
Selection.ShapeRange.TextFrame2.TextRange.Font.Size = 20
Selection.ShapeRange.TextFrame2.TextRange.Font.Italic = msoTrue

BubbleChart.Chart.Legend.Select
Selection.Delete
BubbleChart.Chart.Axes(xlCategory).AxisTitle.Select
Selection.Format.TextFrame2.TextRange.Font.Size = 18
BubbleChart.Chart.Axes(xlValue).AxisTitle.Select
Selection.Format.TextFrame2.TextRange.Font.Size = 18

BubbleChart.Chart.Axes(xlCategory).Select
With Selection.TickLabels.Font
.Size = 13
.Bold = True
End With
BubbleChart.Chart.Axes(xlValue).Select
With Selection.TickLabels.Font
.Size = 13
.Bold = True
End With
' BubbleChart.Chart.Activate
End Sub

Filipe,

the problem appears to be in your loop

For c = 1 To SelectionLength
With BubbleChart.Chart.SeriesCollection.NewSeries
Words = Selection.Cells(1, c)
Words = Trim(Left(Application.WorksheetFunction.Substitute(Words, " ", _
Application.WorksheetFunction.Rept(" ", 100)), 300))
.Name = Words
End With
Next

so c goes from 1 to the number of columns and that assigns the series to start from the column of the first selected cell and then contigously for SelectionLength number of columns.

What you need is to have an array of column numbers measured from and including the first selected column such as

v(1) = 1
v(2) = 3
v(3) = 7
v(4) = 8

then you could alter your current loop to be
for i = 1 to SelectionLength
c = v(i)
With BubbleChart.Chart.SeriesCollection.NewSeries
Words = Selection.Cells(1, c)
Words = Trim(Left(Application.WorksheetFunction.Substitute(Words, " ", _
Application.WorksheetFunction.Rept(" ", 100)), 300))
.Name = Words
End With

Next

to get such an array, you can alter

Selection.Interior.Color = RGB(146, 208, 80)
SelectionLength = Intersect(UserRange, UserRange(1, 1).EntireRow).Cells.Count

to be:

Dim v As Variant
Dim i As Long, j as long
Dim cell As Range
Selection.Interior.Color = RGB(146, 208, 80)
SelectionLength = Intersect(UserRange, UserRange(1, 1).EntireRow).Cells.Count

ReDim v(1 To SelectionLength)
i = 1
j = selection(1,1).column - 1
For Each cell In Intersect(UserRange, UserRange(1, 1).EntireRow).Cells
v(i) = cell.Column - j
i = i + 1
Next

That will build the array needed by the Looping code I talked about.

I don't have your data and so forth, so I can't test the whole routine, but I tested the part that builds the array of selected columns (v) and that worked fine.

(you can declare the variables at the top - I just put the declarations in so you would know what they are.)

--
Regards,
Tom Ogilvy
Questioner's Rating
 Rating(1-10) Knowledgeability = 10 Clarity of Response = 10 Politeness = 10 Comment Tom, thank you so much for your help!!!! Your idea was awesome. It did what I wanted to do, and now everything works the way it is supposed to. You were also incredibly fast at responding, with great kindness, and knowledge. You rock, and should definitely win volunteer of the month. Thanks a bunch!!!!

This topic answers questions related to Microsoft Excel spreadsheet (or workbook) stand-alone or Mircrosoft Office Excel including Excel 2003, Excel 2007, Office 2000, and Office XP. You can get Excel help on Excel formulas(or functions), Excell macros, charting in Excel, advanced features, and the general use of Excel. This does not provide a general Excel tutorial nor the basics of using a spreadsheet. It provides specific answers to using Microsoft Excel only. If you do not see your Excel question answered in this area then please ask an Excel question here

Tom Ogilvy

Expertise

Selected as an Excel MVP by Microsoft since 1999. Answering Excel questions in Allexperts since its inception in 2001. Able to answer questions on almost all aspects of Excel's internal capabilities. If seeking a VBA solution, please specify that in your question itself so I give you the answer you want. [Excel has weak protection - if you are distributing an application, I don't answer questions on how to protect your project from your users.]

Experience

Extensive experience.

Education/Credentials
Master of Science (MS) degree Operations Research (ORSA)

Awards and Honors
Microsoft MVP in Excel.