| |
▼オイスター さん：
>maverick さん
>
>お返事が大変遅くなってしまい申し訳ありません。さらに一つ教えて頂きたいことが出てまいりました。maverickさんの教えてくださった一番最初のプログラムで試してみたのですが、とりあえず思った通りに動きました。しかし一番最後の成績表に貼り付けられたグラフの裏には前の二人分のグラフが重なって残っていました。これは仕方がないことなのでしょうか？消すことはできないのでしょうか？印刷マクロも組み込みますので、特に影響はないと思われますが、気になったらどうしようもありませんので、質問させて頂きました。よろしくお願いします。
>
消すだけならループを使わなければいいだけです。
重なってしまっているのはオイスター さんのコードがそうなっているからですよ！
>For k = 2 To 4
〜中略〜
> ActiveChart.Location Where:=xlLocationAsObject, Name:="Sheet2"
〜中略〜
>Next k
ループの中で作成される全てのグラフが"Sheet2"に作成されています。
シートを別にするか、グラフ位置をズラしてやる必要があります。
サンプルは試してみましたか？
サンプルでは
・人数分ループ
> For k = 2 To Range("A65536").End(xlUp).Row
・シートが足りない場合は追加
> If k > Worksheets.Count Then
> Worksheets.Add After:=Worksheets(k - 1)
> ActiveSheet.Name = "Sheet" & k
> End If
・kに対応するシートにグラフを作成
> .Location Where:=xlLocationAsObject, Name:="Sheet" & k
という仕様になっています。
ついでに、少し整形処理を加えたものを
Sub test()
Dim k As Long, i As Integer
Dim msht As Worksheet
Dim csht As Worksheet
Application.ScreenUpdating = False
Set msht = Sheets("Sheet1")
For k = 2 To msht.Range("A65536").End(xlUp).Row
If k > Worksheets.Count Then
Set csht = Worksheets.Add(After:=Worksheets(k - 1))
csht.Name = "Sheet" & k
Else
Set csht = Sheets("Sheet" & k)
End If
With csht
.Range("B5").Value = msht.Range("A1").Value
.Range("C5").Value = msht.Range("A" & k).Value
Call SetRng(.Range("B5:C5"))
.Range("B8").Resize(, 3).Value = msht.Range("B1").Resize(, 3).Value
For i = 2 To 4
.Cells(9, i).Value = msht.Cells(k, i).Value & "点"
Next i
Call SetRng(.Range("B8:D9"))
.ChartObjects.Delete
End With
With csht.ChartObjects.Add(300, 50, 200, 200).Chart
.ChartType = xlRadarMarkers
.SetSourceData Source:=msht.Range(msht.Cells(k, 2), msht.Cells(k, 4)), PlotBy:=xlRows
.SeriesCollection(1).XValues = "=Sheet1!R1C2:R1C4"
.Location Where:=xlLocationAsObject, Name:="Sheet" & k
.Axes(xlValue).MaximumScale = 100
.Axes(xlValue).MajorUnit = 25
.HasLegend = False
End With
csht.Range("A1").Activate
Set csht = Nothing
Next k
msht.Activate
Set msht = Nothing
Application.ScreenUpdating = False
End Sub
Function SetRng(rng As Range)
With rng
.Borders(xlEdgeLeft).LineStyle = xlContinuous
.Borders(xlEdgeTop).LineStyle = xlContinuous
.Borders(xlEdgeBottom).LineStyle = xlContinuous
.Borders(xlEdgeRight).LineStyle = xlContinuous
If .Rows.Count > 1 Then
.Borders(xlInsideHorizontal).LineStyle = xlContinuous
End If
If .Columns.Count > 1 Then
.Borders(xlInsideVertical).LineStyle = xlContinuous
End If
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.Font.Size = 12
End With
End Function
|
|
maverick
- 06/11/29(水) 22:52 -
