[[20041214003848]]　『グラフの作成』（kou）　ページの最後に飛ぶ

[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]

　

『グラフの作成』（kou）

A列に１、２、３、・・・５０と2行から51行まで番号、Ｂ列に2行から51行まで氏名、ＣからＧ列の2行から51行まで五教科の点数、ボタンを押すと番号を聞き、その番号の学生の五教科の点数分布を表すグラフを表示させたい。この要件を満たすプログラムを作成したいのです。ただ、グラフは何を使用してもかまわないが、出来るだけ教科の得手・不得手がはっきり分るように表示させるものを選択したいのです。どなたか教えてください。

---

 上記の件で判らない部分はどこでしょうか。
 文章だけ読むとプログラムの作成依頼に見えてしまいます。
 自分でどこまでやって何が判らないかを、具体的な例を挙げて質問してみてください。
 （川野鮎太郎）

---

 ユーザーフォームとかグラフはあまり得意じゃないんだけど、自分自身の練習のために
作ってみました。よかったら参考にしてみてください。
フォームのモジュールに
Option Explicit
Sub MyChartLoad()
With Worksheets("Sheet2")
    If .ChartObjects.Count = 0 Then
        MyChartAdd Range("B1", Range("G2")), Range("J4"), Range("O14")
    End If
End With
Set MyChart = Worksheets("Sheet2").ChartObjects(1).Chart
MyChartName = "MyChart.gif"
MyChart.Export MyChartName, "GIF"
Me.Image1.Picture = LoadPicture(MyChartName)
End Sub
Private Sub CommandButton1_Click()
Dim MyTbl As Range
    Worksheets("Sheet1").Range("A1:H1").Copy _
    Destination:=Worksheets("Sheet2").Range("J1")
With Worksheets("Sheet2")
    .Cells(2, 10).Value = Me.TextBox1.Value
    .Cells(2, 11).Value = Me.TextBox2.Value
    .Cells(2, 12).Value = Me.TextBox3.Value
    .Cells(2, 13).Value = Me.TextBox4.Value
    .Cells(2, 14).Value = Me.TextBox5.Value
    .Cells(2, 15).Value = Me.TextBox6.Value
    .Cells(2, 16).Value = Me.TextBox7.Value
    .Cells(2, 17).Value = Me.TextBox8.Value
    If .ChartObjects.Count = 0 Then
        MyChartAdd Range("B1", Range("G2")), Range("J4"), Range("O14")
    End If
    .Range("A1").CurrentRegion.ClearContents
    MyRow = Worksheets("Sheet1").Range("A65536").End(xlUp).Row
    Set MyTbl = Sheets("Sheet1").Range("A1:H" & MyRow)
    MyTbl.AdvancedFilter xlFilterCopy, .Range("J1:Q2"), .Range("A1"), True
    .Range("A:G").EntireColumn.AutoFit
    Me.TextBox1.Value = .Cells(2, 1).Value
    Me.TextBox2.Value = .Cells(2, 2).Value
    Me.TextBox3.Value = .Cells(2, 3).Value
    Me.TextBox4.Value = .Cells(2, 4).Value
    Me.TextBox5.Value = .Cells(2, 5).Value
    Me.TextBox6.Value = .Cells(2, 6).Value
    Me.TextBox7.Value = .Cells(2, 7).Value
    Me.TextBox8.Value = .Cells(2, 8).Value
End With
MyChartLoad
End Sub
Private Sub CommandButton2_Click()
    With Worksheets("Sheet2")
        If .ChartObjects.Count = 0 Then
            MyChartAdd Range("B1", Range("G2")), Range("J4"), Range("O14")
        End If
    End With
    ActiveCell.Select
End Sub
Private Sub CommandButton3_Click()
    Unload Me
End Sub
Private Sub CommandButton4_Click()
    Me.TextBox1.Value = ""
    Me.TextBox2.Value = ""
    Me.TextBox3.Value = ""
    Me.TextBox4.Value = ""
    Me.TextBox5.Value = ""
    Me.TextBox6.Value = ""
    Me.TextBox7.Value = ""
    Me.TextBox8.Value = ""
End Sub
Private Sub UserForm_Initialize()
Dim i As Variant
MyChartLoad
Me.Image1.AutoSize = True
With Worksheets("Sheet1")
    Me.Label1.Caption = .Cells(1, 1).Value
    Me.Label2.Caption = .Cells(1, 2).Value
    Me.Label3.Caption = .Cells(1, 3).Value
    Me.Label4.Caption = .Cells(1, 4).Value
    Me.Label5.Caption = .Cells(1, 5).Value
    Me.Label6.Caption = .Cells(1, 6).Value
    Me.Label7.Caption = .Cells(1, 7).Value
    Me.Label8.Caption = .Cells(1, 8).Value
End With
With Worksheets("Sheet2")
    Me.TextBox1.Value = .Cells(2, 1).Value
    Me.TextBox2.Value = .Cells(2, 2).Value
    Me.TextBox3.Value = .Cells(2, 3).Value
    Me.TextBox4.Value = .Cells(2, 4).Value
    Me.TextBox5.Value = .Cells(2, 5).Value
    Me.TextBox6.Value = .Cells(2, 6).Value
    Me.TextBox7.Value = .Cells(2, 7).Value
    Me.TextBox8.Value = .Cells(2, 8).Value
End With
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    If CloseMode <> vbFormCode Then
        Cancel = 1
    End If
End Sub
標準モジュールに
Option Explicit
Public MyRow As Long
Public MyRng As Range
Public MyChart As Chart
Public MyChartName As String
Sub MyChartAdd(MySouce As Range, MyChatLT As Range, MyWH As Range)
Dim MyChatWH As Range
With Worksheets("Sheet2")
    If .ChartObjects.Count = 0 Then
        Set MyChatWH = .Range(MyChatLT.Address, MyWH.Address)
        .Columns("J:O").ColumnWidth = 6
        .ChartObjects.Add(MyChatLT.Left, MyChatLT.Top, MyChatWH.Width, MyChatWH.Height).Select
        .ChartObjects(1).Chart.ChartType = xlRadarMarkers
        .ChartObjects(1).Chart.SetSourceData Source:=MySouce, PlotBy:=xlRows
        With .ChartObjects(1)
            .Chart.Legend.Position = xlCorner
            .Chart.PlotArea.Top = 30
            .Chart.PlotArea.Left = 20
            .Chart.PlotArea.Width = .Width
            .Chart.PlotArea.Height = .Height
                With .Chart.ChartGroups(1).RadarAxisLabels
                    .AutoScaleFont = False
                    .Font.Size = 10
                End With
                With .Chart.Axes(xlValue).TickLabels
                    .AutoScaleFont = False
                    .Font.Size = 10
                End With
        End With
        .Shapes(1).Placement = xlFreeFloating
    End If
End With
End Sub
http://ryusendo.no-ip.com/cgi-bin/upload/src/up0192.xls
恥ずかし``r(^^;)ぽりぽり
（SoulMan）

---

 ゴシゴシ(-_＼)(/_-)三( ゜Д゜) ス、スゲー!
 （川野鮎太郎）

---

 マクロができない私はこう考えました。
 特定のセル(a)に番号を入れ、それを基に、あるセル範囲(b)にその人の成績をVLOOKUPで抽出します。
 (b)のデータを基に、グラフを作ります。
 後は、(a)に番号を入れれば、グラフはその人の成績を示します。
 (ちゅうねん)

---

 トピ主さんが不在ですが、授業は、続くぅ〜〜〜なぁ〜〜んちゃって
複数抽出できた時に前後も表示できるようにバァ〜〜ジョンあっぷぅしましたぁ
完全に自己満足の世界でぇ〜〜〜っす！！
ではでは、
フォームモジュールに
Option Explicit
Sub MyChartLoad()
With Worksheets("Sheet2")
    If .ChartObjects.Count = 0 Then
        MyChartAdd Range("B1", Range("G2")), Range("J4"), Range("O14")
    End If
End With
Set MyChart = Worksheets("Sheet2").ChartObjects(1).Chart
MyChartName = "MyChart.gif"
On Error Resume Next
    MyChart.Export MyChartName, "GIF"
    Me.Image1.Picture = LoadPicture(MyChartName)
On Error GoTo 0
End Sub
Sub MyNext(ByVal x As Long)
    With Worksheets("Sheet2")
        If .ChartObjects.Count > 0 Then
            .ChartObjects(1).Chart.SeriesCollection(1).Values = .Range("C" & x & ":G" & x).Value
            .ChartObjects(1).Chart.SeriesCollection(1).Name = .Range("B" & x).Value
        End If
    End With
    MyChartLoad
End Sub
Sub MyInpt(ByVal x As Long)
    With Worksheets("Sheet2")
        Me.TextBox1.Value = .Cells(x, 1).Value
        Me.TextBox2.Value = .Cells(x, 2).Value
        Me.TextBox3.Value = .Cells(x, 3).Value
        Me.TextBox4.Value = .Cells(x, 4).Value
        Me.TextBox5.Value = .Cells(x, 5).Value
        Me.TextBox6.Value = .Cells(x, 6).Value
        Me.TextBox7.Value = .Cells(x, 7).Value
        Me.TextBox8.Value = .Cells(x, 8).Value
    End With
End Sub
Private Sub CommandButton1_Click()
i = 2
Dim MyTbl As Range
    Worksheets("Sheet1").Range("A1:H1").Copy _
    Destination:=Worksheets("Sheet2").Range("J1")
    With Worksheets("Sheet2")
        .Cells(2, 10).Value = Me.TextBox1.Value
        .Cells(2, 11).Value = Me.TextBox2.Value
        .Cells(2, 12).Value = Me.TextBox3.Value
        .Cells(2, 13).Value = Me.TextBox4.Value
        .Cells(2, 14).Value = Me.TextBox5.Value
        .Cells(2, 15).Value = Me.TextBox6.Value
        .Cells(2, 16).Value = Me.TextBox7.Value
        .Cells(2, 17).Value = Me.TextBox8.Value
        If .ChartObjects.Count = 0 Then
            MyChartAdd Range("B1", Range("G2")), Range("J4"), Range("O14")
        End If
        .Range("A1").CurrentRegion.ClearContents
        MyRow = Worksheets("Sheet1").Range("A65536").End(xlUp).Row
        Set MyTbl = Sheets("Sheet1").Range("A1:H" & MyRow)
        MyTbl.AdvancedFilter xlFilterCopy, .Range("J1:Q2"), .Range("A1"), True
        .Range("A:G").EntireColumn.AutoFit
        MyInpt i
        .ChartObjects(1).Chart.SeriesCollection(1).Name = .Range("B2").Value
    End With
MyChartLoad
End Sub
Private Sub CommandButton2_Click()
    With Worksheets("Sheet2")
        If .ChartObjects.Count = 0 Then
            MyChartAdd Range("B1", Range("G2")), Range("J4"), Range("O14")
        End If
    End With
    ActiveCell.Select
End Sub
Private Sub CommandButton3_Click()
    Unload Me
End Sub
Private Sub CommandButton4_Click()
    MyInpt Worksheets("Sheet2").Range("A65536").End(xlUp).Offset(1).Row
End Sub
Private Sub CommandButton5_Click()
    i = i + 1
    With Worksheets("Sheet2")
        If Not IsEmpty(.Cells(i, 1)) Then
            MyNext i
            MyInpt i
        Else
            MsgBox "次はありません"
            i = .Range("A65536").End(xlUp).Row
        End If
    End With
End Sub
Private Sub CommandButton6_Click()
    i = i - 1
    If i > 1 Then
        MyNext i
        MyInpt i
    Else
        MsgBox "前はありません"
        i = 2
    End If
End Sub
Private Sub UserForm_Initialize()
i = 2
MyChartLoad
Me.Image1.AutoSize = True
With Worksheets("Sheet1")
    Me.Label1.Caption = .Cells(1, 1).Value
    Me.Label2.Caption = .Cells(1, 2).Value
    Me.Label3.Caption = .Cells(1, 3).Value
    Me.Label4.Caption = .Cells(1, 4).Value
    Me.Label5.Caption = .Cells(1, 5).Value
    Me.Label6.Caption = .Cells(1, 6).Value
    Me.Label7.Caption = .Cells(1, 7).Value
    Me.Label8.Caption = .Cells(1, 8).Value
End With
With Worksheets("Sheet2")
    MyInpt i
End With
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    If CloseMode <> vbFormCode Then
        Cancel = 1
    End If
End Sub
標準モジュールに
Option Explicit
Public MyRow As Long
Public MyRng As Range
Public MyChart As Chart
Public MyChartName As String
Public i As Long
Sub MyChartAdd(ByVal MySouce As Range, ByVal MyChatLT As Range, ByVal MyWH As Range)
Dim MyChatWH As Range
    With Worksheets("Sheet2")
        If .ChartObjects.Count = 0 Then
            Set MyChatWH = .Range(MyChatLT.Address, MyWH.Address)
            .Columns("J:O").ColumnWidth = 6
            .ChartObjects.Add(MyChatLT.Left, MyChatLT.Top, MyChatWH.Width, MyChatWH.Height).Select
            .ChartObjects(1).Chart.ChartType = xlRadarMarkers
            .ChartObjects(1).Chart.SetSourceData Source:=MySouce, PlotBy:=xlRows
            With .ChartObjects(1)
                .Chart.Legend.Position = xlCorner
                .Chart.PlotArea.Top = 30
                .Chart.PlotArea.Left = 20
                .Chart.PlotArea.Width = .Width
                .Chart.PlotArea.Height = .Height
                    With .Chart.ChartGroups(1).RadarAxisLabels
                        .AutoScaleFont = False
                        .Font.Size = 10
                    End With
                    With .Chart.Axes(xlValue).TickLabels
                        .AutoScaleFont = False
                        .Font.Size = 10
                    End With
            End With
            .Shapes(1).Placement = xlFreeFloating
        End If
    End With
End Sub
シート2に
Private Sub Worksheet_Activate()
    ActiveCell.Select
End Sub
ThisBookに
Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
    Cancel = True
    UserForm1.Show 0
    Target.Select
End Sub
http://ryusendo.no-ip.com/cgi-bin/upload/src/up0193.xls
どうでしょう？
v(=∩_∩=)v
（SoulMan）

---

すいません。次からはもっと明確な質問をするよう心掛けます。皆さん、ありがとうございます。大変参考になり、なんとかなりました。

 （kou）

---

コメント返信：

---

[ 一覧(最新更新順) ]

---

YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki. Modified by kazu.