Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。

  新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム  
6524 / 13646 ﾂﾘｰ ←次へ　｜　前へ→
▼ 【44686】成績表にグラフを入れるマクロ オイスター 06/11/28(火) 21:23 質問[未読]
【44688】Re:成績表にグラフを入れるマクロ maverick 06/11/28(火) 23:07 回答[未読]
【44718】Re:成績表にグラフを入れるマクロ オイスター 06/11/29(水) 20:21 質問[未読]
【44720】Re:成績表にグラフを入れるマクロ maverick 06/11/29(水) 22:52 回答[未読]
【44721】Re:成績表にグラフを入れるマクロ ichinose 06/11/29(水) 23:46 発言[未読]
【44763】Re:成績表にグラフを入れるマクロ オイスター 06/11/30(木) 21:07 お礼[未読]
【44686】成績表にグラフを入れるマクロ
質問  オイスター  - 06/11/28(火) 21:23 -
引用なし
パスワード
   みなさま、お忙しいところ申し訳ありませんが、お知恵をお貸しください。

現在、学校の成績表を作っています。生徒が３００人ほどいますが、校内模試の個人個人の結果をグラフとともに一人ずつ成績表にして印刷し、返却したいと思っています。

グラフを入れずに成績表マクロを作成するとすんなりといくのですが、グラフを入れたとたんに「Cellsメソッドは失敗しました。Globalオブジェクト」と警告が出ます。

Sheet1には、とりあえず３名の得点があります。

A1から横に「名前」「国語」「英語」「社会」
A2から横に「ちあき」+３教科の個々の得点
A3から横に「しのぶ」＋３教科の個々の得点
A4から横に「ゆり」＋３教科の個々の得点

Sheet2に「レーダー」グラフを出そうと思い、以下のマクロを作成してみました。皆様からすれば、非常に無駄の多いマクロだと思われますが、初心者ですので、このまま微修正を頂ければ幸いです。

どうぞよろしくご指導ください。失礼します。


Sub Macro3()
'
' Macro3 Macro
' マクロ記録日 : 2006/11/28　ユーザー名 : TARA SHIZUYA
'

'
For k = 2 To 4
　　Charts.Add
　　ActiveChart.ChartType = xlRadarMarkers
　　ActiveChart.SetSourceData Source:=Sheets("Sheet1").Range(Cells(k, 2), Cells(k, 4)), PlotBy:= _
　　　　xlRows
　　ActiveChart.SeriesCollection(1).XValues = "=Sheet1!R1C2:R1C4"
　　ActiveChart.Location Where:=xlLocationAsObject, Name:="Sheet2"
　　ActiveChart.HasTitle = False
　　ActiveWindow.Visible = False
　　Windows("Book1").Activate
Next k
　　Range("A1").Select
End Sub
【44688】Re:成績表にグラフを入れるマクロ
回答  maverick  - 06/11/28(火) 23:07 -
引用なし
パスワード
   >　　ActiveChart.SetSourceData Source:=Sheets("Sheet1").Range(Cells(k, 2), Cells(k, 4)), PlotBy:= _
>　　　　xlRows
↓
　　ActiveChart.SetSourceData _
　　　　Source:=Sheets("Sheet1").Range(Sheets("Sheet1").Cells(k, 2), _
　　　　　　　　　　Sheets("Sheet1").Cells(k, 4)), PlotBy:=xlRows
又は
　　　　With Sheets("Sheet1")
　　　　　　ActiveChart.SetSourceData Source:=.Range(.Cells(k, 2), .Cells(k, 4)), PlotBy:=xlRows
　　　　End With
など

――――――――――――――――――――――――――――――――――――

サンプル

Sub Macro3()
　　Dim k As Long
　　Dim sht As Worksheet

　　Set sht = Sheets("Sheet1")
　　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
　　　　With Charts.Add
　　　　　　.ChartType = xlRadarMarkers
　　　　　　.SetSourceData Source:=sht.Range(sht.Cells(k, 2), sht.Cells(k, 4)), PlotBy:=xlRows
　　　　　　.SeriesCollection(1).XValues = "=Sheet1!R1C2:R1C4"
　　　　　　.Location Where:=xlLocationAsObject, Name:="Sheet" & k
　　　　End With
　　　　Range("A1").Select
　　Next k
End Sub
【44718】Re:成績表にグラフを入れるマクロ
質問  オイスター  - 06/11/29(水) 20:21 -
引用なし
パスワード
   maverick さん

お返事が大変遅くなってしまい申し訳ありません。さらに一つ教えて頂きたいことが出てまいりました。maverickさんの教えてくださった一番最初のプログラムで試してみたのですが、とりあえず思った通りに動きました。しかし一番最後の成績表に貼り付けられたグラフの裏には前の二人分のグラフが重なって残っていました。これは仕方がないことなのでしょうか？消すことはできないのでしょうか？印刷マクロも組み込みますので、特に影響はないと思われますが、気になったらどうしようもありませんので、質問させて頂きました。よろしくお願いします。


▼：
>>　　ActiveChart.SetSourceData Source:=Sheets("Sheet1").Range(Cells(k, 2), Cells(k, 4)), PlotBy:= _
>>　　　　xlRows
>↓
>　　ActiveChart.SetSourceData _
>　　　　Source:=Sheets("Sheet1").Range(Sheets("Sheet1").Cells(k, 2), _
>　　　　　　　　　　Sheets("Sheet1").Cells(k, 4)), PlotBy:=xlRows
>又は
>　　　　With Sheets("Sheet1")
>　　　　　　ActiveChart.SetSourceData Source:=.Range(.Cells(k, 2), .Cells(k, 4)), PlotBy:=xlRows
>　　　　End With
>など
>
>――――――――――――――――――――――――――――――――――――
>
>サンプル
>
>Sub Macro3()
>　　Dim k As Long
>　　Dim sht As Worksheet
>
>　　Set sht = Sheets("Sheet1")
>　　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
>　　　　With Charts.Add
>　　　　　　.ChartType = xlRadarMarkers
>　　　　　　.SetSourceData Source:=sht.Range(sht.Cells(k, 2), sht.Cells(k, 4)), PlotBy:=xlRows
>　　　　　　.SeriesCollection(1).XValues = "=Sheet1!R1C2:R1C4"
>　　　　　　.Location Where:=xlLocationAsObject, Name:="Sheet" & k
>　　　　End With
>　　　　Range("A1").Select
>　　Next k
>End Sub
【44720】Re:成績表にグラフを入れるマクロ
回答  maverick  - 06/11/29(水) 22:52 -
引用なし
パスワード
   ▼オイスター さん：
>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
【44721】Re:成績表にグラフを入れるマクロ
発言  ichinose  - 06/11/29(水) 23:46 -
引用なし
パスワード
   こんばんは。
どうして、生徒の数だけグラフオブジェクトを作るのですか？
印刷が目的なら印刷用レイアウトシートにグラフオブジェクトはひとつ作成すれば
良いと思いますが・・・。
生徒氏名と得点だけ差し込むだけで足りると思いますよ！！

Sheet1というシートに以下の成績データがあるとします。

　　　　Ａ　　　Ｂ　　　Ｃ　　　Ｄ
　１　氏名　　　国語　　英語　　社会
　２　Ａ　　　　30　　　77　　　40
　３　Ｂ　　　　47　　　72　　　36
　４　Ｃ　　　　26　　　33　　　51


この表を個人別成績表にして印刷することを考えます。

標準モジュールに

'===========================================================
Sub sample()
　　Dim idx As Long
　　Dim rw As Long
　　Dim rng As Range
　　Dim sht As Worksheet
　　With Worksheets("sheet1")
　　　 Set sht = Workbooks.Add.ActiveSheet
　　　 Set rng = mk_print_area(sht)
　　　 sht.Activate
　　　 rng.Select
　　　 rw = .Cells(.Rows.Count, 1).End(xlUp).Row
　　　 For idx = 2 To rw
　　　　　rng.Value = .Range(.Cells(idx, 1), .Cells(idx, 4)).Value
　　　　
　　　　　sht.PrintOut
　　　　　Next idx
　　　 End With
　　sht.Parent.Close False
End Sub
'======================================================================
Function mk_print_area(sht As Worksheet) As Range
　　Dim locate As Variant
　　With sht
　　　 .Rows("4:7").RowHeight = 27
　　　 With .Range("b4")
　　　　　.Value = "模擬試験成績表"
　　　　　End With
　　　 .Columns("B:B").ColumnWidth = 28.75
　　　 With .Range("B6:e7")
　　　　　.Rows(1).Value = Array("氏名", "国語", "英語", "社会")
　　　　　For Each locate In Array(xlEdgeLeft, xlEdgeTop, xlEdgeBottom, xlEdgeRight, xlInsideVertical, xlInsideHorizontal)
　　　　　　 With .Borders(locate)
　　　　　　　　.LineStyle = xlNone
　　　　　　　　.Weight = xlThin
　　　　　　　　.ColorIndex = xlAutomatic
　　　　　　　　End With
　　　　　　 Next
　　　　　.Rows(2).Value = Array("dummy", 100, 100, 100)
　　　　　End With
　　　 With .Parent.Charts.Add
　　　　 .ChartType = xlRadar
　　　　 .SetSourceData Source:=sht.Range("C6:E7"), PlotBy:=xlRows
　　　　 .SeriesCollection(1).Name = "=" & sht.Name & "!r7c2"
　　　　 With .Location(Where:=xlLocationAsObject, Name:=sht.Name)
　　　　　 .Parent.Left = sht.Range("b10").Left
　　　　　 .Parent.Top = sht.Range("b10").Top
　　　　　 .Parent.Width = sht.Range("b10:e10").Width
　　　　　 End With
　　　　 End With
　　　 .Range("b7:e7").ClearContents
　　　 Set mk_print_area = .Range("b7:e7")
　　　 End With
　　
End Function

これで上記の生徒の成績表を個別に印刷できます。

私は、説明の都合上、動的に差込シート（グラフのあるシート）を作成しましたが、

これは予め準備しておいても良いと思います。
（実際にやるなら、私はそうします）
試してみてください。
【44763】Re:成績表にグラフを入れるマクロ
お礼  オイスター  - 06/11/30(木) 21:07 -
引用なし
パスワード
   maverickさん、ichinose さん

この件につきまして、丁寧なご回答を頂き本当に感謝しています。お二人からご提案頂きましたすべてのプログラムを試してみました。

無事作成が出来ました！

お礼が遅くなってしまい申し訳ありませんでした。

失礼します。
  新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム  
6524 / 13646 ﾂﾘｰ ←次へ　｜　前へ→
ページ：  ┃  記事番号：
2610219
(SS)C-BOARD v3.8 is Free