質問をすることでしか得られない、回答やアドバイスがある。

15分調べてもわからないことは、質問しよう!

ただいまの
回答率

89.11%

VBAでグラフを一括でつくる

解決済

回答 2

投稿

  • 評価
  • クリップ 0
  • VIEW 118

izuki_y

score 64

お世話になっております。
表題の件で質問をさせてください。

環境:
Windows 10 Pro x64
Excel 2016

前回の質問を元にVBAでグラフ作成までを完成させました。
VBAでグラフを作るとExcelが落ちる
VBAでグラフの特定要素を色付けしたい

最後に複数の表で各列毎(月ごと)にグラフを作りたいです。
二次元!!

Option Explicit
Sub AddGraph()

    'グラフの対象データ範囲を定義
    Dim trgtSh As Worksheet
    Set trgtSh = ThisWorkbook.Worksheets("Sheet1")
    Dim dataRng As Range
    Set dataRng = trgtSh.Range("A1").CurrentRegion '行が増えても大丈夫


    'グラフを貼り付けたいセルを定義
    Dim pasteRng As Range
    Set pasteRng = trgtSh.Range("D6")

    'グラフの対象データをソートする(昇順) 
    ' 複数列の場合はここも変えないといけない
    With trgtSh
        .Sort.SortFields.Clear
        .Sort.SortFields.Add Key:=.Range("B1"), Order:=xlAscending  '第1優先
        .Sort.SortFields.Add Key:=.Range("A1"), Order:=xlAscending  '第2優先
        .Sort.SetRange dataRng  'ソートの範囲
        .Sort.Header = xlYes '先頭のセルはヘッダ?それともデータ?
        .Sort.Apply
    End With

    'グラフ編集
    With trgtSh.Shapes.AddChart2.Chart

        'グラフの種類を指定(ここでは「集合縦棒」)
        .ChartType = xlColumnClustered
        'グラフの対象データ範囲を指定
        .SetSourceData dataRng

        Dim tmp As Variant, I As Long
        tmp = .SeriesCollection(1).XValues

        For I = 1 To UBound(tmp)
            If InStr(tmp(I), "Product 10") > 0 Then
                With .SeriesCollection(1).Points(I)
                    .Interior.ColorIndex = 3
                    .ApplyDataLabels
                End With
            End If      

        'グラフタイトルを非表示
        .HasTitle = False

        'グラフのフォントを"Meiryo UI"、フォントサイズを"10"にする
        With .ChartArea.Format.TextFrame2.TextRange.Font
            .Size = 10
            .NameComplexScript = "Meiryo UI"
            .NameFarEast = "Meiryo UI"
            .Name = "Meiryo UI"
        End With


        'グラフの貼り付け位置を指定
        .Parent.Top = pasteRng.Top
        .Parent.Left = pasteRng.Left
    End With

End Sub

ご教授よろしくお願いいたします。

  • 気になる質問をクリップする

    クリップした質問は、後からいつでもマイページで確認できます。

    またクリップした質問に回答があった際、通知やメールを受け取ることができます。

    クリップを取り消します

  • 良い質問の評価を上げる

    以下のような質問は評価を上げましょう

    • 質問内容が明確
    • 自分も答えを知りたい
    • 質問者以外のユーザにも役立つ

    評価が高い質問は、TOPページの「注目」タブのフィードに表示されやすくなります。

    質問の評価を上げたことを取り消します

  • 評価を下げられる数の上限に達しました

    評価を下げることができません

    • 1日5回まで評価を下げられます
    • 1日に1ユーザに対して2回まで評価を下げられます

    質問の評価を下げる

    teratailでは下記のような質問を「具体的に困っていることがない質問」、「サイトポリシーに違反する質問」と定義し、推奨していません。

    • プログラミングに関係のない質問
    • やってほしいことだけを記載した丸投げの質問
    • 問題・課題が含まれていない質問
    • 意図的に内容が抹消された質問
    • 過去に投稿した質問と同じ内容の質問
    • 広告と受け取られるような投稿

    評価が下がると、TOPページの「アクティブ」「注目」タブのフィードに表示されにくくなります。

    質問の評価を下げたことを取り消します

    この機能は開放されていません

    評価を下げる条件を満たしてません

    評価を下げる理由を選択してください

    詳細な説明はこちら

    上記に当てはまらず、質問内容が明確になっていない質問には「情報の追加・修正依頼」機能からコメントをしてください。

    質問の評価を下げる機能の利用条件

    この機能を利用するためには、以下の事項を行う必要があります。

質問への追記・修正、ベストアンサー選択の依頼

  • izuki_y

    2020/06/30 09:24

    作るだけたら選択範囲を変更すれば出来るとおもったけどグラフの表示を昇順ソートしてくれと言われた。

    これはもう別セルにグラフ用の分解した表を作るしかないのかもしれない

    キャンセル

  • radames1000

    2020/07/01 09:15

    1月グラフを作成後2月データでソートすると1月グラフの並びが崩れます。
    対処案としては二つ思いつきました。
    1.別表を作成する
    2.一度作ったグラフを画像にする
    どれが質問者さんの意図に沿うでしょうか。

    キャンセル

  • izuki_y

    2020/07/04 00:36

    返信が遅れて申し訳ありません。
    ご回答ありがとうございます。
    内容に関しては仰る通りです。

    画像だとペーストのパラメータを変更させればよいので楽かなと思いますが、
    汎用性が無くなるので個人的にはNGかなと思っています。

    別表を作ってそれぞれで表を作成するのが一番かなと思っております。
    作業が滞っていた間に、「ソートしろ」、「MinとMaxの要素に対してデータラベルの追加を行え」、「月ごとのAverage(平均)を追加して色を変更しろ」と次々に注文が入って困りますw

    tosiさんソースをベースに変更してみようと思います。
    同じ様に別表を作る関数を作ってやってみようと思います。

    また困った事がありましたら是非協力をお願いいたします。

    キャンセル

回答 2

checkベストアンサー

+1

こんな感じでしょうか。(修正を加えてみました)

Option Explicit

Sub Test_Sample_Miniature()

    Dim WorkChart As Chart
    Dim lngTop As Long, lngHeight As Long

    Set WorkChart = AddGraph("A1:A17,B1:C17", "A1")
    lngTop = WorkChart.Parent.Top + WorkChart.Parent.Height

    Set WorkChart = AddGraph("A1:A17,B1:B17", "A1")
    WorkChart.Parent.Top = lngTop
    lngTop = lngTop + WorkChart.Parent.Height

    Set WorkChart = AddGraph("A1:A17,C1:C17", "A1")
    WorkChart.Parent.Top = lngTop
    lngTop = lngTop + WorkChart.Parent.Height

    Set WorkChart = AddGraph("A1:A17,D1:D17", "A1")
    WorkChart.Parent.Top = lngTop

End Sub

Function AddGraph(ByVal strDataArea As String, ByVal strKeySel As String) As Chart

    'グラフの対象データ範囲を定義
    Dim trgtSh As Worksheet
    Set trgtSh = ThisWorkbook.Worksheets("Sheet1")
    Dim dataRng As Range
    Set dataRng = trgtSh.Range("A1").CurrentRegion '行が増えても大丈夫


    'グラフを貼り付けたいセルを定義
    Dim pasteRng As Range
    Set pasteRng = trgtSh.Range("D6")

    'グラフの対象データをソートする(昇順)
    ' 複数列の場合はここも変えないといけない
    With trgtSh
        .Range(strDataArea).Select
        .Sort.SortFields.Clear
        .Sort.SortFields.Add Key:=.Range(strKeySel), Order:=xlAscending  '第1優先
        .Sort.SortFields.Add Key:=.Range("A1"), Order:=xlAscending  '第2優先
        .Sort.SetRange dataRng  'ソートの範囲
        .Sort.Header = xlYes '先頭のセルはヘッダ?それともデータ?
        .Sort.Apply
    End With

    'グラフ編集
    Set AddGraph = trgtSh.Shapes.AddChart.Chart
    With AddGraph

        'グラフの種類を指定(ここでは「集合縦棒」)
        .ChartType = xlColumnClustered

        'グラフの対象データ範囲を指定
        '.SetSourceData dataRng

        Dim tmp As Variant, I As Long
        tmp = .SeriesCollection(1).XValues

        For I = 1 To UBound(tmp)
            If InStr(tmp(I), "Product 10") > 0 Then
                With .SeriesCollection(1).Points(I)
                    .Interior.ColorIndex = 3
                    .ApplyDataLabels
                End With
            End If
        Next

        'グラフタイトルを非表示
        .HasTitle = False

        'グラフのフォントを"Meiryo UI"、フォントサイズを"10"にする
        With .ChartArea.Format.TextFrame2.TextRange.Font
            .Size = 10
            .NameComplexScript = "Meiryo UI"
            .NameFarEast = "Meiryo UI"
            .Name = "Meiryo UI"
        End With

        'グラフの貼り付け位置を指定
        .Parent.Top = pasteRng.Top
        .Parent.Left = pasteRng.Left

    End With

End Function

投稿

  • 回答の評価を上げる

    以下のような回答は評価を上げましょう

    • 正しい回答
    • わかりやすい回答
    • ためになる回答

    評価が高い回答ほどページの上位に表示されます。

  • 回答の評価を下げる

    下記のような回答は推奨されていません。

    • 間違っている回答
    • 質問の回答になっていない投稿
    • スパムや攻撃的な表現を用いた投稿

    評価を下げる際はその理由を明確に伝え、適切な回答に修正してもらいましょう。

  • 2020/07/04 00:28

    返信が遅くなって申し訳ございません。
    内容をコピペさせて頂き期待に沿う形になった事を確認いたしました。
    関数化して引数で汎用性を持たせる例を教えて頂きありがとうございます。

    ものすごく参考になりました。
    ベストアンサーにさせてください。

    キャンセル

0

ベストアンサーを選んだ上で
解決方法を書いたらどうなるんだろうか?

せっかく答えて頂いたベストアンサーが消えたりしないよね?

ベストアンサーが取り消されたらごめん。
テスト的に書いてみます。

投稿

  • 回答の評価を上げる

    以下のような回答は評価を上げましょう

    • 正しい回答
    • わかりやすい回答
    • ためになる回答

    評価が高い回答ほどページの上位に表示されます。

  • 回答の評価を下げる

    下記のような回答は推奨されていません。

    • 間違っている回答
    • 質問の回答になっていない投稿
    • スパムや攻撃的な表現を用いた投稿

    評価を下げる際はその理由を明確に伝え、適切な回答に修正してもらいましょう。

15分調べてもわからないことは、teratailで質問しよう!

  • ただいまの回答率 89.11%
  • 質問をまとめることで、思考を整理して素早く解決
  • テンプレート機能で、簡単に質問をまとめられる