特殊グラフの作り方を教えて下さい

質問

図のような車の価格帯表をエクセルで作成しています。いつも、手書きで作成している為、価格が変わる都度書き直しているので大変手間が掛かってしまいます。そこで、手書きでは無く、グラフを使って価格帯を作成したく何度かトライしたのですが、どうも上手く作れません。

株価チャートに使用するろうそくグラフを応用してグラフを作成してみましたが、これもダメでした。何か上手い方法で価格帯をグラフにする方法を知っている方、作り方を教えて下さい。

宜しくお願い申し上げます。

回答No.1

mitarashi

セルのコピー画像を散布図のマーカーにするというアイデアをVBAコード化してみました。
縦線はご自分で引いて下さい。VBAのお勉強をしているよりは、都度手書きする方が早いかも。
元データの構造は、添付画像のグラフ内に貼り付けてあります。ご参考まで。

Sub test()
Dim sh As Worksheet
Dim myChart As Chart
Dim dataRange As Range, labelRange As Range
Dim i As Long, chartobjcount As Long

Set sh = ThisWorkbook.Worksheets(1)
With sh
Set dataRange = .Range(.Range("B2"), .Range("B" & .Rows.Count).End(xlUp))
Set dataRange = dataRange.Offset(0, -1).Resize(, 4)
Set labelRange = .Range(.Range("G2"), .Range("G" & .Rows.Count).End(xlUp))
Set labelRange = labelRange.Offset(0, -1).Resize(, 3)
End With

chartobjcount = sh.ChartObjects.Count
Set myChart = Charts.Add
myChart.Location Where:=xlLocationAsObject, Name:=sh.Name
With sh.ChartObjects(chartobjcount + 1)
Set myChart = .Chart
.Width = 600
.Height = 400
End With
myChart.ChartType = xlXYScatter

With myChart
.SeriesCollection.NewSeries
.SeriesCollection(1).XValues = dataRange.Columns(2)
.SeriesCollection(1).Values = dataRange.Columns(4)
.SeriesCollection(1).Name = dataRange.Columns(2).Cells(1).Item(0).Value
.SeriesCollection.NewSeries
.SeriesCollection(2).XValues = labelRange.Columns(2)
.SeriesCollection(2).Values = labelRange.Columns(3)
.SeriesCollection(2).Name = labelRange.Columns(2).Cells(1).Item(0).Value
.SeriesCollection(2).MarkerStyle = -4142
.HasLegend = False
.PlotArea.Height = .PlotArea.Height - 20
End With
myChart.PlotArea.Border.Color = vbBlack
With myChart.SeriesCollection(1)
For i = 1 To dataRange.Rows.Count
dataRange.Columns(3).Cells(i).Resize(, 2).CopyPicture Appearance:=xlScreen, Format:=xlPicture
.Points(i).Paste
Next i
End With
With myChart.Axes(xlCategory)
.MinimumScale = 0
.MaximumScale = 5
.MajorUnit = 1
.HasMinorGridlines = False
.TickLabels.NumberFormatLocal = """"""
End With
With myChart.Axes(xlValue)
.HasMajorGridlines = False
End With
For i = 1 To labelRange.Rows.Count
With myChart.SeriesCollection(2).Points(i)
.HasDataLabel = True
.DataLabel.Top = .DataLabel.Top + 10
.DataLabel.Left = .DataLabel.Left - 25
.DataLabel.Text = labelRange.Columns(1).Cells(i).Value
End With
Next i
End Sub