Excel VBA質問箱 IV

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

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


6522 / 13644 ツリー ←次へ | 前へ→

【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 -

引用なし
パスワード
   みなさま、お忙しいところ申し訳ありませんが、お知恵をお貸しください。

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

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

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

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

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というシートに以下の成績データがあるとします。

    A   B   C   D
 1 氏名   国語  英語  社会
 2 A    30   77   40
 3 B    47   72   36
 4 C    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 さん

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

無事作成が出来ました!

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

失礼します。

6522 / 13644 ツリー ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free