| |
いつもお世話になります。前回の質問ではお礼も述べず放置してしまい申し訳ありませんでした。皆さんに回答して頂き、マクロの機能としては揃いましたので各動作の最適化、軽量化を進めようと思い見直すとやはり作図の部分がネックになります。中でも”データラベル”の表示作業が重いようなので、これについて教えてください。
やりたいことは、ある2点間を線で結び一方の点に任意の文字を表示させると言うものです。２点がそのつど位置が変わり、固定されない複数SETであるため、TextBox等では難しいと考えデータラベルを配置しTEXTを書き換えるという方法を選びました。しかし一度、線を挿入した後これを選択し書き換えると言う方法のため、（例では７２本ですが）描画に非常に時間がかかります。
参考リストを掲載しますのでアドバイス宜しくお願いいたします。
Sub MakeDATA()'作図用のデータをSheet1に作ります。
For i = 0 To 71
With Worksheets("Sheet1")
.Cells(4 + i, 1).Value = i * 5
.Cells(4 + i, 2) = 0
.Cells(4 + i, 3) = "=10*COS(PI()*RC[-2]/180)"
.Cells(4 + i, 4) = 0
.Cells(4 + i, 5) = "=10*sin(PI()*RC[-4]/180)"
End With
Next i
End Sub
Sub MakeCharts() '作図用のグラフ１をsheet1に作ります。
Worksheets("Sheet1").Select
Charts.Add
With ActiveChart
.ChartType = xlXYScatter
.SetSourceData Source:=Sheets("Sheet1").Range("I12")
.Location Where:=xlLocationAsObject, Name:="Sheet1"
End With
End Sub
Sub 描画() '本題の作図作業を行います。
Dim Ch As ChartObject
Dim DL_Name As Variant
Dim i As Integer, j As Integer, k As Integer, Line_Color As Integer
Dim l As Double, m As Double
Set Ch = ActiveSheet.ChartObjects("グラフ 1")
Application.ScreenUpdating = False '画面更新停止し、ちょびっと高速化
i = Ch.Chart.SeriesCollection.Count + 1
j = 4
k = Worksheets("Sheet1").Range("B4").End(xlDown).Row
While j <= k
With Ch.Chart.SeriesCollection.NewSeries
.XValues = "=Sheet1!R" & j & "C2:R" & j & "C3"
.Values = "=Sheet1!R" & j & "C4:R" & j & "C5"
.Name = "No_" & j
.Border.ColorIndex = 1
.Border.Weight = xlHairline
.Border.LineStyle = xlContinuous
End With
'−−−直線の２番目の点にのみラベル表示（数値は任意：今回は角度）−−−
Set DL_Name = Ch.Chart.SeriesCollection(i).Points(2).DataLabel
Ch.Chart.SeriesCollection(i).Points(2).ApplyDataLabels Type:= _
xlDataLabelsShowLabel, AutoText:=True, LegendKey:=False
DL_Name.Characters.Text = Worksheets("Sheet1").Cells(j, 1).Value
DL_Name.AutoScaleFont = False
With DL_Name.Characters(Start:=1, Length:=4).Font
.Name = "ＭＳ Ｐゴシック"
.Size = 8
End With
i = i + 1: j = j + 1
'−−−−−−−−−−−−−−−−−−−−−−−−−−
Wend
Application.ScreenUpdating = True '画面更新再開
Set Ch = Nothing 'クリアー
Set DL_Name = Nothing 'クリアー
End Sub
Sub 線消去()
Dim Ch As ChartObject
Dim i As Integer
Set Ch = ActiveSheet.ChartObjects("グラフ 1")
i = Ch.Chart.SeriesCollection.Count
Application.ScreenUpdating = False
While i > 0
Ch.Chart.SeriesCollection(i).Delete
i = i - 1
Wend
Application.ScreenUpdating = True
Set Ch = Nothing
End Sub
>書式設定は、デフォルトの設定では目的と違って、実現しないようなものについて
>のみ行えば良いのです。
についてですが、例えば1〜50番目までは直線、51番目から破線と言うようなとき50番目の描画が終わった時点でデフォールト設定を破線へと変更できるものなのでしょうか？こちらについても解答お願いします。
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
