[[20190824214813]]　『VBAで複数の表からグラフを順に作成する』（TK）　ページの最後に飛ぶ

『VBAで複数の表からグラフを順に作成する』（TK）

ヒストグラムをVBAで作成しようと試みています。

   ABCD　　E　　Ｆ…RＳ　　　Ｔ      U    V    W    X       Y         Z     AA    AB    AC  　 AD…
41     　商品名　　　　　　　ｸﾞﾗﾌﾀｲﾄﾙ1                     ｸﾞﾗﾌﾀｲﾄﾙ2                          ｸﾞﾗﾌﾀｲﾄﾙ3…
42
43　　　　　　　　　　値　　 0      25    50   75   100      0  　　 　50 　150　　200　　0      0…
44　　　　　　　　　 度数　　0　　　1　　　0　　0　　0   　  0 　       0  　 2 　  0 　  0   　 0…
45
46
47
48
49
︙︙︙︙…

このような形となっており、
Ａ-Ｄ列、S列～は作業列としています。
表はいずれも5列で構成されており、
ｸﾞﾗﾌﾀｲﾄﾙ1のデータはＴ43：Ｘ44、ｸﾞﾗﾌﾀｲﾄﾙ2のデータはＹ43：AC44、ｸﾞﾗﾌﾀｲﾄﾙ3だとAD43:AH44…と続いていきます。

これをｸﾞﾗﾌﾀｲﾄﾙ1から順にE48から2列おき(G50,I50…に横に並べていきたいのですが
そのような方法はあるでしょうか？

グラフタイトル1分だけの作成は下記に示すコードでできたのですが、
これを連続して作成していくとなるとどうすればよいか分かりませんでした。
是非お知恵を拝借させて頂きたく、宜しくお願いいたします。

Sub Test1()

  With ActiveSheet.Shapes.AddChart.Chart
    '横棒グラフ追加
    .ChartType = xlBarClustered
    .SetSourceData Range("T44:X44")
    .SetElement msoElementDataLabelOutSideEnd  'データラベル表示

    .HasTitle = True     'タイトルの追加

    With .ChartTitle
    .Text = Range("T41").Text 'タイトル名設定
    .Font.Size = 8
     End With

    '軸の最小値・最大値変更
    .Axes(xlValue).MaximumScale = 10
    .Axes(xlValue).MinimumScale = 0
    .Axes(xlValue, xlPrimary).CategoryNames = _
      Range("T43:X43")
           '---Y軸ラベルを指定した文字列に変更
    .Axes(xlCategory).TickLabels.Font.Size = 8 'Y軸のフォント変更

  '凡例を消す
    Dim cho As ChartObject

  For Each cho In ActiveSheet.ChartObjects
    cho.Chart.HasLegend = False
  Next cho

    With ActiveSheet.ChartObjects
        .Top = Range("E48").Top
        .Left = Range("E48").Left '位置を設定
        .Height = 150
        .Width = 100 '大きさを設定

    End With

  End With

＜使用 Excel：Excel2016、使用 OS：Windows7 ＞

コード　最後にEnd Subが抜けています。申し訳ありません。

（TK） 2019/08/24(土) 23:11

こんな感じで複製できますので、組み合わせるとよいです。

 Sub グラフ複製()
    Dim cho As ChartObject
    Dim tbl As Range
    Dim pos As Range
    Dim L As Double, T As Double

    Set cho = ActiveSheet.ChartObjects(1)
    Set tbl = Range("T43:X44")
    Set pos = Range("E48")

    Do
        Set tbl = tbl.Offset(, 5)
        If tbl(1).Value = "" Then Exit Do
        Set pos = pos.Offset(, 2)

        With cho.Duplicate
            .Left = pos.Left
            .Top = cho.Top
             .Chart.SeriesCollection(1).XValues = tbl.Rows(1)
             .Chart.SeriesCollection(1).Values = tbl.Rows(2)
             .Chart.ChartTitle.Text = tbl(-1, 1).Text
        End With
    Loop

 End Sub

（マナ） 2019/08/25(日) 08:29

返信ありがとうございます!!!
狙い通りの実行できました。
この度は親切にお答え頂きありがとうございました。
（TK） 2019/08/25(日) 23:59

質問と関係ありませんが

↓は、ループ必要ないです？

 ＞  '凡例を消す
 ＞    Dim cho As ChartObject
 ＞  For Each cho In ActiveSheet.ChartObjects
 ＞    cho.Chart.HasLegend = False
 ＞  Next cho

ほかも部分も整理すると

 Sub test2()
    Dim cht As Chart
    Dim tbl As Range
    Dim pos As Range
    Dim ser As Series

    Set tbl = Range("T43:X44")
    Set pos = Range("E48")

    Set cht = ActiveSheet.Shapes.AddChart( _
            xlBarClustered, pos.Left, pos.Top, 100, 150).Chart

    With cht
        Set ser = .SeriesCollection.NewSeries
        ser.XValues = tbl.Rows(1)
        ser.Values = tbl.Rows(2)

        .ChartArea.Font.Size = 8
        .SetElement msoElementLegendNone
        .SetElement msoElementDataLabelOutSideEnd
        .SetElement msoElementChartTitleAboveChart
        .ChartTitle.Formula = "=" & tbl(-1, 1).Address(, , , True)
        .Axes(xlValue).MaximumScale = 10
        .Axes(xlValue).MinimumScale = 0
    End With

 End Sub

（マナ） 2019/08/26(月) 21:33

コメント返信：

[ 一覧(最新更新順) ]

[[20190824214813]] 『VBAで複数の表からグラフを順に作成する』（TK） ページの最後に飛ぶ

[[20190824214813]]　『VBAで複数の表からグラフを順に作成する』（TK）　ページの最後に飛ぶ