ここから始めましょう。データをソート/再ソートするたびにマクロ「UpdateChart」を実行する必要がありますが、これは私にとってはうまくいっているようです。
マクロでいくつか作成Namesし、一連の Values & XValues をそれらの範囲に設定しますが、これは厳密には必要ではありません。
Sub UpdateChart()
Dim cht As Chart
Dim srs As Series
Dim s1xVals As Range
Dim s1Vals As Range
Dim s1Test As Double
Dim s2Test As Double
Dim nmAddress As String
Dim nm1 As Name
Dim nm2 As Name
Dim parAVals As Range
Set parAVals = GetRange("Define the ParA range?")
Set s1xVals = GetRange("X Values?")
Set s1Vals = GetRange("Y Values?")
s1Test = Application.InputBox("What filter value for ParA?", "Series 1 Filter")
s2Test = Application.InputBox("What filter value for ParA?", "Series 2 Filter")
'Get the address of all cells matching the filter rule for series 1.'
nmAddress = GetAddress(s1xVals, parAVals, s1Test)
'Add the name to the workbook:'
ActiveWorkbook.Names.Add Name:="Srs1_XValues", RefersTo:=Range(nmAddress), Visible:=True
'Repeat for the Y Values'
nmAddress = GetAddress(s1Vals, parAVals, s1Test)
ActiveWorkbook.Names.Add Name:="Srs1_YValues", RefersTo:=Range(nmAddress), Visible:=True
'Repeat for series 2:'
nmAddress = GetAddress(s1xVals, parAVals, s2Test)
ActiveWorkbook.Names.Add Name:="Srs2_XValues", RefersTo:=Range(nmAddress), Visible:=True
nmAddress = GetAddress(s1Vals, parAVals, s2Test)
ActiveWorkbook.Names.Add Name:="Srs2_YValues", RefersTo:=Range(nmAddress), Visible:=True
Set cht = ActiveSheet.ChartObjects(1).Chart '## Modify as needed.'
'remove any existing data in the chart, or modify as needed.'
For Each srs In cht.SeriesCollection
srs.Delete
Next
'Add the first series:'
Set srs = cht.SeriesCollection.NewSeries
srs.XValues = Range("srs1_XValues")
srs.Values = Range("srs1_YValues")
srs.Name = "Series 1 Name" '## modify as needed.'
'Add the second series:'
Set srs = cht.SeriesCollection.NewSeries
srs.XValues = Range("srs2_xValues")
srs.Values = Range("srs2_YValues")
srs.Name = "Series 2 Name" '## modify as needed.'
End Sub
Function GetAddress(srsVals As Range, filterVals As Range, filterCriteria As Double)
Dim cl As Range
Dim c As Long: c = 1
Dim tmpAddress As String
For Each cl In filterVals
If cl.Value = filterCriteria Then
Debug.Print srsVals.Cells(c).Value
'Create a string value of cell address matching criteria'
If tmpAddress = vbNullString Then
tmpAddress = srsVals.Cells(c).Address
Else:
tmpAddress = tmpAddress & "," & srsVals.Cells(c).Address
End If
End If
c = c + 1
Next
GetAddress = tmpAddress
End Function
Private Function GetRange(msg As String) As Range
Set GetRange = Application.InputBox(msg, Type:=8)
End Function
リビジョン
上記のメソッドは、255 文字を超える文字列を返すと失敗し、アドレスをNameシリーズに割り当てることができません。
これは、 を使用しない修正バージョンですNames。フィルター処理されたスコアを配列に収集し、それらの値を使用してシリーズを定義するだけです。
上記のソリューションと同様に、データを変更するたびに実行する必要があります。
Sub UpdateChartNoNames()
Dim cht As Chart
Dim srs As Series
Dim s1xVals As Range
Dim s1Vals As Range
Dim s1Test As Double
Dim s2Test As Double
Dim parAVals As Range
Set parAVals = GetRange("Define the ParA range?")
Set s1xVals = GetRange("X Values?")
Set s1Vals = GetRange("Y Values?")
'## Alternatively, you could set these ranges without using the inputbox:'
'Set parAvals = Range("C2:C300") '
'Set s1XVals = Range("A2:A300") '
'Set s1Vals = Range("B2:B300") '
s1Test = Application.InputBox("What filter value for ParA?", "Series 1 Filter")
s2Test = Application.InputBox("What filter value for ParA?", "Series 2 Filter")
Set cht = ActiveSheet.ChartObjects(1).Chart '## Modify as needed.'
'remove any existing data in the chart, or modify as needed.'
For Each srs In cht.SeriesCollection
srs.Delete
Next
'Add the first series:'
Set srs = cht.SeriesCollection.NewSeries
srs.XValues = GetValues(s1xVals, parAVals, s1Test)
srs.Values = GetValues(s1Vals, parAVals, s1Test)
srs.Name = "Series 1 Name" '## modify as needed.'
'Add the second series:'
Set srs = cht.SeriesCollection.NewSeries
srs.XValues = GetValues(s1xVals, parAVals, s2Test)
srs.Values = GetValues(s1Vals, parAVals, s2Test)
srs.Name = "Series 2 Name" '## modify as needed.'
End Sub
Function GetValues(srsVals As Range, filterVals As Range, filterCriteria As Double) As Variant
Dim cl As Range
Dim c As Long: c = 0
Dim tmpVar As Variant
ReDim tmpVar(0)
For Each cl In filterVals
If cl.Value = filterCriteria Then
'Debug.Print srsVals.Cells(c).Value'
'Create a string value of cell address matching criteria'
ReDim Preserve tmpVar(c)
tmpVar(c) = srsVals.Cells(c).Value
c = c + 1
End If
Next
GetValues = tmpVar
End Function
Private Function GetRange(msg As String) As Range
Set GetRange = Application.InputBox(msg, Type:=8)
End Function