Excel VBA グラフ操作

Sub グラフ作成()
Const 表示シート As String = "生徒数"
Dim クラス行 As Integer
Dim 学年 As String
Dim クラス As String
Dim グラフデータ As Range
Dim グラフ描画エリア As Range

   Worksheets(表示シート).Activate
   If ActiveSheet.ChartObjects.Count > 0 Then    '既存のグラフがあれば
      ActiveSheet.ChartObjects.Delete            '全て削除する
   End If

    'B列(2列目)を基準に最後の行まで処理。
    'クラスは2行で一組なので、行数を2で整数割り算してクラス数を求めている。
    For クラス行 = 1 To Cells(ActiveSheet.Rows.Count, 2).End(xlUp).Row \ 2
        
        'アクティブなシートが、グラフシートに移る前に、
        'ワークシートのセルデータを変数に格納しておく。
        Worksheets(表示シート).Activate
        '新しい「学年」データが出現したら、変数「学年」に収納し直す。
        If Range("A1").Cells(クラス行 * 2, 1).Value <> "" Then
            学年 = Range("A1").Cells(クラス行 * 2, 1).Value
        End If
        クラス = Range("B1").Cells(クラス行 * 2, 1).Value
        
        Set グラフデータ _
        = Union(Range("C1").Resize(1, 2), Range("C1").Cells(クラス行 * 2, 1).Resize(2, 2))
        'Resizeは、ワークシートを参照するため、グラフに移る前に、セルのレンジを変数に格納しておく。

        'グラフを、10行の高さ、5列の大きさで、1行置きに描く。
        Set グラフ描画エリア = Range("H1").Cells(クラス行 * 11 - 10, 1).Resize(10, 5)

        ActiveSheet.ChartObjects.Add _
            Left:=グラフ描画エリア.Left, Top:=グラフ描画エリア.Top, _
            Width:=グラフ描画エリア.Width, Height:=グラフ描画エリア.Height
        
        With ActiveSheet.ChartObjects(クラス行).Chart
            .ChartType = xlPie
            .SetSourceData _
                Source:=グラフデータ _
                , PlotBy:=xlColumns
'            .HasTitle = True 'Excel97で動かないので、コメントアウト
            .ChartTitle.Characters.Text = 学年 & クラス
        End With
        
        '***********************************
        '以下は、グラフの体裁を修正しているだけです。
        ActiveSheet.ChartObjects(クラス行).Activate

        ActiveChart.ChartArea.Select
'       Excel97〜用
        ActiveChart.ApplyDataLabels _
            Type:=xlDataLabelsShowLabelAndPercent _
            , LegendKey:=False _
            , HasLeaderLines:=True

'       Excel2003専用
'        ActiveChart.ApplyDataLabels _
'            AutoText:=True _
'            , LegendKey:=False _
'            , HasLeaderLines:=True
'            , ShowSeriesName:=True _
'            , ShowCategoryName:=True _
'            , ShowValue:=True _
'            , ShowPercentage:=True _
'            , ShowBubbleSize:=False


        ActiveChart.Legend.Select
        ActiveChart.Legend.LegendEntries(1).LegendKey.Select
        With Selection.Border
            .Weight = xlThin
            .LineStyle = xlAutomatic
        End With
        Selection.Shadow = False
        With Selection.Interior
            .ColorIndex = 3
            .Pattern = xlSolid
        End With
        ActiveChart.Legend.LegendEntries(2).LegendKey.Select
        With Selection.Border
            .Weight = xlThin
            .LineStyle = xlAutomatic
        End With
        Selection.Shadow = False
        With Selection.Interior
            .ColorIndex = 5
            .Pattern = xlSolid
        End With

        ActiveChart.PlotArea.Select
            Selection.Width = 70
            Selection.Height = 70
            Selection.Left = 70
            Selection.Top = 30
        '***********************************

        ActiveChart.ChartArea.Select
        ActiveWindow.Visible = False
        Worksheets(表示シート).Activate
        Range("A1").Select
    Next クラス行
End Sub

Dim ch As ChartObject
Set ch = Worksheets("sheet1").ChartObjects.Add(100, 30, 400, 250)
ch.Chart.ChartWizard source:=Worksheets("sheet1").Range("a1:a20"), _
    gallery:=xlLine, title:="New Chart"

Worksheets("Sheet1").ChartObjects(1).Chart. _
    ChartArea.Interior.Pattern = xlLightDown

With Worksheets("Sheet1").ChartObjects(1).Chart
    .HasTitle = True
    .ChartTitle.Text = "1995 年月間降水量"
End With

Worksheets("Sheet1").ChartObjects(1).Activate
ActiveChart.SeriesCollection.Add _
    source:=Worksheets("Sheet1").Range("B1:B10")

Worksheets("Sheet1").ChartObjects(1).Chart.ChartArea.ClearFormats

Charts("Chart1").Legend.LegendEntries(1).Font.Name = "ＭＳ Ｐゴシック"

Option Explicit
Option Base 1

Sub ニ軸グラフ()

Dim グラフデータ(2) As Range
Dim グラフ描画エリア As Range

   '「Sheet1」シートに移動して、グラフ用のデータを取得
   ThisWorkbook.Worksheets("Sheet1").Activate
   Set グラフデータ(1) = Range("A1:A5,D1:D5") '棒グラフ用
   Set グラフデータ(2) = Range("C2:C5")       '折れ線グラフ用

   '「Sheet2」シートに移動して、グラフを作成
   ThisWorkbook.Worksheets("Sheet2").Activate
   Set グラフ描画エリア = Range("B2:G15")
   
   ActiveSheet.ChartObjects.Add _
   Left:=グラフ描画エリア.Left, Top:=グラフ描画エリア.Top, _
   Width:=グラフ描画エリア.Width, Height:=グラフ描画エリア.Height
        
   With ActiveSheet.ChartObjects(1).Chart
      .ChartType = xlColumnClustered       '棒グラフ★★★
       .SetSourceData Source:=グラフデータ(1) _
           , PlotBy:=xlColumns             '列をデータ系列として使用
      .HasTitle = False                    'グラフ名を表示しない
      .HasLegend = True                    '凡例付き
      .HasDataTable = False
      .SeriesCollection(1).HasDataLabels = True 'データラベルを表示する
      .Axes(xlValue).MaximumScale = 100000 '軸の最大値を100,000に固定する
      .Axes(xlValue).HasTitle = True       '軸タイトルを表示する
      .Axes(xlValue).AxisTitle.Text = "金額(円)"
      .PlotArea.Interior.ColorIndex = 2    'グラフの背景色を、グレーではなく、白にする
   End With

   ActiveSheet.ChartObjects(1).Activate
   '新しくデータ系列を作成
   ActiveChart.SeriesCollection.NewSeries
   'グラフの種類、データの範囲、凡例、2軸の使用を指定。
   With ActiveChart.SeriesCollection(2)
      .ChartType = xlLineMarkers           '折れ線グラフ★★★
      'データの指定
      .Values = グラフデータ(2)
      .HasDataLabels = True                'データラベルを表示する
      .Name = "数"                         '凡例用の名前
      .AxisGroup = 2                       '第2軸にする
   End With
   With ActiveChart
         .Axes(2, 2).MaximumScale = 150 '2軸目の最大値を150に固定する
         .Axes(2, 2).HasTitle = True    '2軸目のタイトルを表示する
         .Axes(2, 2).AxisTitle.Text = "数"
   End With
   
   Set グラフ描画エリア = Nothing
   Set グラフデータ(1) = Nothing
   Set グラフデータ(2) = Nothing
      
   Range("A1").Select

End Sub

With Charts("chart1").Axes(xlCategory)
    .HasTitle = True
    .AxisTitle.Caption = "1994"
End With

Option Explicit

'******************************************************
Sub 散布図作成()
'******************************************************
   
   Dim 学年 As String
   Dim 学年前 As String
   Dim グラフデータ(3, 3) As Range 'X軸、Y軸、系列名
   Dim 基本グラフデータ As Range
   Dim グラフ描画エリア As Range
   Dim カウンタ As Integer
   Dim しきい行 As Integer
   Dim 最終行 As Integer
   Dim 処理行 As Integer
   Dim 処理列 As Integer
   Dim 横軸名 As String
   Dim 縦軸名 As String
   
   
   ThisWorkbook.Worksheets("Sheet1").Activate
   最終行 = Cells(ActiveSheet.Rows.Count, 1).End(xlUp).Row
   
   '学年の区切りを判定しながら、散布図用グラフデータを取得

   学年前 = Range("A2").Value
   カウンタ = 1
   しきい行 = 2
   
   For 処理行 = 2 To 最終行
      学年 = Range("A1").Cells(処理行, 1).Value
      If 学年 <> 学年前 Then
         Set グラフデータ(カウンタ, 1) = _
            Range("C1").Cells(しきい行, 1).Resize(処理行 - しきい行, 1) 'X軸：体重
         Set グラフデータ(カウンタ, 2) = _
            Range("D1").Cells(しきい行, 1).Resize(処理行 - しきい行, 1) 'Y軸：身長
         Set グラフデータ(カウンタ, 3) = _
            Range("A1").Cells(しきい行, 1)                              '系列名
         しきい行 = 処理行
         カウンタ = カウンタ + 1
         学年前 = 学年
      End If
   Next 処理行
   
   横軸名 = Range("C1").Value
   縦軸名 = Range("D1").Value
   
   Set グラフデータ(カウンタ, 1) = _
      Range("C1").Cells(しきい行, 1).Resize(処理行 - しきい行, 1) 'X軸：体重
   Set グラフデータ(カウンタ, 2) = _
      Range("D1").Cells(しきい行, 1).Resize(処理行 - しきい行, 1) 'Y軸：身長
   Set グラフデータ(カウンタ, 3) = _
      Range("A1").Cells(しきい行, 1)                              '系列名

   Set 基本グラフデータ = _
   Union(グラフデータ(1, 1), グラフデータ(1, 2)) '一年生のX軸：体重とY軸：身長を合体
   
   
   'グラフを、F2 セルを左上として、18行の高さ、6列の大きさで描く
   Set グラフ描画エリア = Range("F2").Resize(18, 6)

   ActiveSheet.ChartObjects.Add _
       (Left:=グラフ描画エリア.Left, Top:=グラフ描画エリア.Top, _
       Width:=グラフ描画エリア.Width, Height:=グラフ描画エリア.Height) _
       .Name = "散布図"
        
   With ActiveSheet.ChartObjects("散布図").Chart
      .ChartType = xlXYScatter                                        '散布図
      .SetSourceData Source:=基本グラフデータ _
          , PlotBy:=xlColumns                                         'データは縦方向に並んでいる
      .SeriesCollection(1).Name = グラフデータ(1, 3)                  '系列名：一年生
      .SeriesCollection.NewSeries
      .SeriesCollection(2).XValues = グラフデータ(2, 1)               '二年生のX軸：体重
      .SeriesCollection(2).Values = グラフデータ(2, 2)                '二年生のY軸：身長
      .SeriesCollection(2).Name = グラフデータ(2, 3)                  '系列名：二年生
      .SeriesCollection.NewSeries
      .SeriesCollection(3).XValues = グラフデータ(3, 1)               '三年生のX軸：体重
      .SeriesCollection(3).Values = グラフデータ(3, 2)                '三年生のY軸：身長
      .SeriesCollection(3).Name = グラフデータ(3, 3)                  '系列名：三年生

      .HasTitle = True
      .ChartTitle.Characters.Text = "中学生の身長と体重"              'グラフ名
      .Axes(xlCategory, xlPrimary).HasTitle = True                    '★横軸名を付ける
      .Axes(xlCategory, xlPrimary).AxisTitle.Characters.Text = 横軸名 '付けるその横軸名
      .Axes(xlValue, xlPrimary).HasTitle = True                       '★縦軸名を付ける
      .Axes(xlValue, xlPrimary).AxisTitle.Characters.Text = 縦軸名    '付けるその縦軸名

      With .Axes(xlCategory)
          .HasMajorGridlines = True                                   '縦スケール線を入れる
          .HasMinorGridlines = False
          .MinimumScale = 20                                          '横軸の最小値を20にする
      End With

      With .Axes(xlValue)
          .HasMajorGridlines = True                                   '横スケール線を入れる
          .HasMinorGridlines = False
          .MinimumScale = 100                                         '縦軸の最小値を100にする
      End With

      With .SeriesCollection(1)
'         .MarkerStyle = 3
         .MarkerSize = 5                            '1番目のマーカーのサイズを5に小さくする
      End With
      With .SeriesCollection(2)
'         .MarkerStyle = 3
         .MarkerSize = 3                            '2番目のマーカーのサイズを3に小さくする
      End With
      With .SeriesCollection(3)
'         .MarkerStyle = 3
         .MarkerSize = 5                            '3番目のマーカーのサイズを5に小さくする
      End With

   End With
   
   Range("A1").Select

   'オブジェクトをクリアする
   For 処理行 = 1 To 3
      For 処理列 = 1 To 3
         Set グラフデータ(処理行, 処理列) = Nothing
      Next 処理列
   Next 処理行
   
   Set グラフ描画エリア = Nothing
   
End Sub

Option Explicit

Dim ヒストグラム分析ツール As String
Dim 拡張子 As String

'******************************************************
Sub 縦棒グラフ作成()
'******************************************************
   Dim グラフデータ As Range
   Dim グラフ描画エリア As Range
   Dim 軸データ As Range
   Dim 最終行 As Integer
   
   Call OSのバージョンとExcelのバージョン取得
   
   '前回の処理の度数データが残っていれば、削除
   ThisWorkbook.Worksheets("縦棒グラフ用集計表").Activate
   Range("E1").CurrentRegion.Delete
   Range("A1").Select

   ThisWorkbook.Worksheets("Sheet1").Activate
   最終行 = Cells(ActiveSheet.Rows.Count, 1).End(xlUp).Row
      
   'Excel 2003 と 2007 以降では、分析ツールの拡張子が違う
   Application.Run ヒストグラム分析ツール _
      , ActiveSheet.Range("D1").Resize(最終行, 1) _
      , Worksheets("縦棒グラフ用集計表").Range("D1:D12") _
      , Worksheets("縦棒グラフ用集計表").Range("A1:A11") _
      , False, False, False, True
   'ヒストグラム出力範囲にデータがあります。上書きする場合は [OK] を押してください。
   
   'グラフに移る前に、セルのレンジを変数に格納しておく。
   ThisWorkbook.Worksheets("縦棒グラフ用集計表").Activate
   
   Range("E1").Value = "中学生徒の身長分布" _
   & vbNewLine & "(総人数 " & 最終行 - 1 & " 人)"
   Set グラフデータ = Range("E1:E11")
   Set 軸データ = Range("B2:B11")
   Range("A1").Select

   ThisWorkbook.Worksheets("Sheet1").Activate
   'グラフを、F21 セルを左上として、18行の高さ、6列の大きさで描く。
   Set グラフ描画エリア = Range("F21").Resize(18, 6)

   ActiveSheet.ChartObjects.Add _
       (Left:=グラフ描画エリア.Left, Top:=グラフ描画エリア.Top, _
       Width:=グラフ描画エリア.Width, Height:=グラフ描画エリア.Height) _
       .Name = "棒グラフ"
        
   With ActiveSheet.ChartObjects("棒グラフ").Chart
    .SetSourceData Source:=グラフデータ
    .ChartType = xlColumnClustered
'    .Axes(xlCategory).Select '★Excel 2003 では外す
    .SeriesCollection(1).XValues = 軸データ
    .HasLegend = False

   End With
   
   '★Excel 2003 用コード。☆これは、Excel 2007 でも使える。
   ActiveSheet.ChartObjects("棒グラフ").Activate
    ActiveChart.ChartArea.Select
    With ActiveChart
        .Axes(xlCategory, xlPrimary).HasTitle = True
        .Axes(xlCategory, xlPrimary).AxisTitle.Characters.Text = "身長(cm)"
        .Axes(xlValue, xlPrimary).HasTitle = True
        .Axes(xlValue, xlPrimary).AxisTitle.Characters.Text = "人"
    End With

    Range("A1").Select
      
End Sub

'******************************************************
Private Sub OSのバージョンとExcelのバージョン取得()
'******************************************************

   Dim OS名 As String
   Dim Excelバージョン As Integer

    OS名 = Application.OperatingSystem
    Excelバージョン = CInt(Application.Version)
            
'            2000 ：5.00
'            XP   ：5.01
'            Vista：6.00

'            2003 ：11.0
'            2007 ：12.0
   If Excelバージョン > 11 Then
      拡張子 = ".xlsx"
      ヒストグラム分析ツール = "ATPVBAEN.XLAM!Histogram"
   Else
      拡張子 = ".xls"
      ヒストグラム分析ツール = "ATPVBAEN.XLA!Histogram"
   End If
   
End Sub

Option Explicit
Option Base 1


'******************************************************
Sub ドーナツグラフ作成()
'******************************************************

   Dim 開始日時 As Variant
   Dim 終了日時 As Variant
   Dim 最終行 As Long
   Dim 処理行 As Long
   Dim 学科科目配列(10, 2)        '学科科目,人数
   Dim 都道府県配列(500, 3)       '都道府県,空白,人数
   Dim 都道府県数 As Integer
   Dim 学科科目数 As Integer
   Dim 都道府県名 As String
   Dim 学科科目名 As String
   Dim ドーナツグラフデータ As Range
   Dim グラフ描画エリア As Range
   Dim その他都道府県人数 As Integer
   Dim 検索都道府県 As Integer

   開始日時 = Now                ' 開始時刻を変数に格納します。
   
'   ' 処理を高速化するため、画面描画停止､自動計算停止
'    Application.ScreenUpdating = False
'    Application.Calculation = xlCalculationManual

   ThisWorkbook.Worksheets("抽出項目データ").Activate
   
   '人数を集計する前処理として、好きな科目､出身地別に並び替え

   Range("A1").CurrentRegion.Sort _
      Key1:=Range("A2"), Order1:=xlAscending, _
      Key2:=Range("B2"), Order2:=xlAscending, _
      Header:=xlYes

   '抽出項目データから、グラフ用に、科目、都道府県単位に人数をカウント
   
   最終行 = Cells(ActiveSheet.Rows.Count, 1).End(xlUp).Row
   
   学科科目数 = 1
   学科科目配列(学科科目数, 1) = Range("A2").Value             '学科科目の一つ目
   都道府県数 = 1
   都道府県配列(都道府県数, 1) = Range("B2").Value             '都道府県の一つ目
   
   For 処理行 = 2 To 最終行
   
      学科科目名 = Range("A1").Cells(処理行, 1).Value
      都道府県名 = Range("B1").Cells(処理行, 1).Value
      
      '学科は、第一キーでソートされているので、重複して出現しない
      If 学科科目名 = 学科科目配列(学科科目数, 1) Then
         学科科目配列(学科科目数, 2) = 学科科目配列(学科科目数, 2) + 1
      Else '新出の学科科目名
         学科科目数 = 学科科目数 + 1
         学科科目配列(学科科目数, 1) = 学科科目名
         学科科目配列(学科科目数, 2) = 学科科目配列(学科科目数, 2) + 1
      End If
      
      '都道府県は、ソートの第一キーではないので、重複出現が有りうる
      For 検索都道府県 = 1 To 都道府県数
         If 都道府県名 = 都道府県配列(検索都道府県, 1) Then
            '既出都道府県
            都道府県配列(検索都道府県, 3) = 都道府県配列(検索都道府県, 3) + 1
            GoTo 次の行へ
         End If
      Next 検索都道府県
      '新出の都道府県
      都道府県数 = 都道府県数 + 1
      都道府県配列(都道府県数, 1) = 都道府県名
      都道府県配列(都道府県数, 3) = 都道府県配列(都道府県数, 3) + 1
次の行へ:
   Next 処理行
   
   
   '集計結果の人数を、"ドーナツグラフと集計表"のシートに、貼り付け
   ThisWorkbook.Worksheets("ドーナツグラフと集計表").Activate
   
   Range("A2").Resize(学科科目数, 2).Value = 学科科目配列
   
   Range("A2").Cells(学科科目数 + 1, 1).Resize(都道府県数, 3).Value = 都道府県配列
   
   
   '学科科目別人数を、人数の多いものから少ないものに降順にソート
   Range("A2").Resize(学科科目数, 2).Sort _
      Key1:=Range("B2"), Order1:=xlDescending, _
      Header:=xlNo
      
   '都道府県別人数を、人数の多いものから少ないものに降順にソート
   Range("A2").Cells(学科科目数 + 1, 1).Resize(都道府県数, 3).Sort _
      Key1:=Range("C2").Cells(学科科目数 + 1, 1), Order1:=xlDescending, _
      Header:=xlNo

   '都道府県数が、11以上の場合は、10位以下を、「その他都道府県」 としてまとめる
   その他都道府県人数 = 0

   If 都道府県数 >= 11 Then
      For 処理行 = 1 + 学科科目数 + 10 To 1 + 学科科目数 + 都道府県数
         その他都道府県人数 = その他都道府県人数 + Range("C1").Cells(処理行, 1).Value
      Next 処理行

      For 処理行 = 1 + 学科科目数 + 10 To 1 + 学科科目数 + 都道府県数
             Rows(1 + 学科科目数 + 10).Delete Shift:=xlUp
      Next 処理行
'Stop
      Range("A1").Cells(1 + 学科科目数 + 10, 1).Value = "その他"
      Range("C1").Cells(1 + 学科科目数 + 10, 1).Value = その他都道府県人数
      都道府県数 = 10
   End If

   Range("A1").Select
   
   'ワークシートを参照するため、グラフに移る前に、セルのレンジを変数に格納しておく。

   Set ドーナツグラフデータ _
   = Range("A1").Resize(学科科目数 + 都道府県数 + 1, 3)
   
   
   'グラフを、E1 のセルを左上として、20行の高さ、10列の大きさで描く。
   Set グラフ描画エリア = Range("E1").Resize(20, 7)

   ActiveSheet.ChartObjects.Add _
       Left:=グラフ描画エリア.Left, Top:=グラフ描画エリア.Top, _
       Width:=グラフ描画エリア.Width, Height:=グラフ描画エリア.Height
   
   '二重ドーナツグラフを描きます。
   With ActiveSheet.ChartObjects(1).Chart
       .ChartType = xlDoughnut
       .SetSourceData _
            Source:=ドーナツグラフデータ, _
            PlotBy:=xlColumns
   '    .Location Where:=xlLocationAsObject, Name:="ドーナツグラフ用集計表"
   End With
   
   'グラフタイトルを表示します。
   ActiveSheet.ChartObjects(1).Activate
   With ActiveSheet.ChartObjects(1).Chart
      .HasTitle = True
      .ChartTitle.Characters.Text = "人数 (総人数 " & 最終行 - 1 & " 人)"
   End With
   
   'ドーナツの穴の大きさを、最小の 10% にちぢめます。
   ActiveSheet.ChartObjects(1).Chart.SeriesCollection(1).Select
    With ActiveChart.ChartGroups(1)
        .VaryByCategories = True
        .FirstSliceAngle = 0
        .DoughnutHoleSize = 10
    End With
    
   'データラベルで、項目名と、数値と、パーセント を表示させます。
   With ActiveSheet.ChartObjects(1).Chart
      .SeriesCollection(1).ApplyDataLabels _
      AutoText:=True, _
      LegendKey:=False, _
      ShowSeriesName:=False, _
      ShowCategoryName:=True, _
      ShowValue:=True, _
      ShowPercentage:=True, _
      ShowBubbleSize:=False
       
      .SeriesCollection(2).ApplyDataLabels _
      AutoText:=True, _
      LegendKey:=False, _
      ShowSeriesName:=False, _
      ShowCategoryName:=True, _
      ShowValue:=True, _
      ShowPercentage:=True, _
      ShowBubbleSize:=False
   End With


   'オブジェクトをクリア

   Set ドーナツグラフデータ = Nothing
   Set グラフ描画エリア = Nothing
   
   Range("A1").Select
   
   ' 画面描画再開､自動計算停止解除
   Application.ScreenUpdating = True
   Application.Calculation = xlCalculationAutomatic

   終了日時 = Now
   MsgBox "処理時間は、" _
   & Format(終了日時 - 開始日時, "hh時間nn分ss秒") & " でした。"

End Sub