https://daitaideit.com/vba-graph-copy/#mokuzi2-3
-- 1. 開発タブの挿入でボタンを作成
※ActiveXコントロールのものを使用する
-- 2. デザインモードONで作成したボタンをダブルクリックするとエディタが開くので下記コードを記載。デザインモードOFFで実行
Option Explicit
Private Sub CommandButton1_Click()
'画面を更新しない
Application.ScreenUpdating = False
'確認メッセージを表示しない
Application.DisplayAlerts = False
'テスト用データ作成
'10行目以下をクリア
Dim LastRow As Long
LastRow = Cells(Rows.Count, 2).End(xlUp).Row
Rows("10:" & LastRow).Delete
Cells(10, 2) = "日付"
Cells(10, 3) = "データ1"
Cells(10, 4) = "データ2"
Cells(10, 5) = "データ3"
'セルヘッダ着色
Range("B10:E10").Interior.Color = RGB(189, 249, 253)
Dim i As Long
For i = 11 To 20
Cells(i, 2).Value = CDate("2024/05/01") + i
Cells(i, 3).Value = CStr(Int(100 * Rnd))
Cells(i, 4).Value = CStr(Int(100 * Rnd))
Cells(i, 5).Value = CStr(Int(100 * Rnd))
Next i
'セル罫線設定
Range("B10:E20").Borders.LineStyle = xlContinuous
'既存のグラフ削除
With ActiveSheet
For i = .ChartObjects.Count To 1 Step -1
.ChartObjects(i).Delete
Next i
End With
'グラフの作成
With ActiveSheet.Shapes.AddChart
'グラフ表示位置とサイズの設定
.top = Range("G3").top
.left = Range("G3").left
.width = 300
.height = 200
With .Chart
'折れ線グラフを指定
.ChartType = xlLine
'グラフにデータシリーズを追加
.SeriesCollection.NewSeries
.SeriesCollection.NewSeries
'X軸のデータを指定
.FullSeriesCollection(1).XValues = Range("B11:B20")
.FullSeriesCollection(2).XValues = Range("B11:B20")
'各データシリーズの範囲
.SeriesCollection(1).Values = Range("D11:D20")
.SeriesCollection(2).Values = Range("E11:E20")
'各データシリーズ名
.SeriesCollection(1).Name = "データ2"
.SeriesCollection(2).Name = "データ3"
'X軸の最大値と最小値
.Axes(xlCategory).MinimumScale = CLng(DateValue("2024/5/12"))
.Axes(xlCategory).MaximumScale = CLng(DateValue("2024/5/21"))
'凡例の表示
.HasLegend = True
'データ2の線を赤色へ変更
.FullSeriesCollection(1).Format.Line.ForeColor.RGB = RGB(255, 0, 0)
'データ3の線を青色へ変更
.FullSeriesCollection(2).Format.Line.ForeColor.RGB = RGB(0, 0, 255)
'X軸の表示形式を指定
.Axes(xlCategory).TickLabels.NumberFormatLocal = "yyyy-mm-dd"
'タイトルの表示
.HasTitle = True
'タイトルの指定
.ChartTitle.Text = "グラフタイトル"
With .ChartTitle.Format.TextFrame2.TextRange.Font
'タイトルサイズ
.Size = 15
'タイトル細字
.Bold = False
End With
End With
End With
'セルリージョンコピー
Dim r As Range
Set r = Range("B10").CurrentRegion
r.Copy Range("B30")
r.Copy Range("B50")
Dim r_rows As String
r_rows = r.Rows.Count
''Debug.Print "r_rows", r_rows
'グラフオブジェクトをオブジェクト変数に格納
Dim chartObj As Variant
Set chartObj = ActiveSheet.ChartObjects(1)
With chartObj
Dim t As String
Dim l As String
Dim w As String
Dim h As String
t = .top
l = .left
w = .width
h = .height
''Debug.Print "t", t
''Debug.Print "l", l
''Debug.Print "w", w
''Debug.Print "h", h
.Copy
End With
With ActiveSheet
.Paste Destination:=Range("G30")
Set chartObj = .ChartObjects(.ChartObjects.Count)
With chartObj
With .Chart
.ChartTitle.Text = "グラフタイトル(追加1)"
'X軸のデータを指定
.FullSeriesCollection(1).XValues = Range("B31:B40")
.FullSeriesCollection(2).XValues = Range("B31:B40")
'各データシリーズの範囲
.SeriesCollection(1).Values = Range("D31:D40")
.SeriesCollection(2).Values = Range("E31:E40")
End With
End With
.Paste Destination:=Range("G50")
Set chartObj = .ChartObjects(.ChartObjects.Count)
With chartObj
With .Chart
.ChartTitle.Text = "グラフタイトル(追加2)"
'X軸のデータを指定
.FullSeriesCollection(1).XValues = Range("B51:B60")
.FullSeriesCollection(2).XValues = Range("B51:B60")
'各データシリーズの範囲
.SeriesCollection(1).Values = Range("D51:D60")
.SeriesCollection(2).Values = Range("E51:E60")
End With
End With
End With
'確認メッセージを表示する
Application.DisplayAlerts = True
'画面を更新する
Application.ScreenUpdating = True
End Sub
