'*************************************************** ' 「ラベル貼りマクロ」 Macro version 2.013 '*************************************************** ' ' マクロ作成日 : 2001/9/17 ユーザー名 : Kenryo INDO ' マクロ修正日 : 2003/5/29 ユーザー名 : Kenryo INDO ' マクロ修正日 : 2013/5/4 ユーザー名 : Kenryo INDO ' 複数のグラフと系列に対応 ' '使い方: '(1)VBAエディターを立ち上げ、当該プロジェクトの標準モジュールを挿入、 '(2)以下のプログラムを貼り付ける。 '(3)グラフかシートを選び、マクロ実行でnameLabelを選択。 'ただし前もってラベルにする範囲の入力を済ませておく。 ' ' メイン: nameLabel() ' ラベリング作業: chartLabelSet() ' 書式変更: shosikiLabel() ' Sub nameLabel() Dim a As Integer For i = 1 To ActiveSheet.ChartObjects.Count a = MsgBox(i & "番目のグラフのラベルを設定します", vbOKCancel, "実行") If a = vbOK Then chartLabelSet (i) End If Next i End Sub Sub chartLabelSet(i As Integer) Dim pts As Points Dim cLabels(20) As String Set obj1 = ActiveSheet.ChartObjects.Item(i) Set chart1 = obj1.Chart Set collection1 = chart1.SeriesCollection For j = 1 To collection1.Count Set series1 = collection1.Item(j) Set pts = series1.Points Set myLabel = Application.InputBox( _ prompt:=j &"番目の系列です。ラベルに使用するセル範囲を選択してください。", Type:=8) ActiveWorkbook.Names.Add Name:="chartLabels", RefersToR1C1:=myLabel For K = 1 To pts.Count cLabels(K) = ActiveSheet.Range("chartLabels").Cells(K, 1).Value Next K obj1.Activate chart1.ApplyDataLabels Type:=xlDataLabelsShowLabel, LegendKey:=False For K = 1 To pts.Count pts(K).DataLabel.Text = cLabels(K) Next K series1.DataLabels.Select With Selection .HorizontalAlignment = xlRight .VerticalAlignment = xlBottom .Position = xlLabelPositionLeft .Orientation = xlHorizontal ' With Selection.Font .Name = "MS Pゴシック" .FontStyle = "太字" .Size = 8 .Strikethrough = False .Superscript = False .Subscript = False .OutlineFont = False .Shadow = False .Underline = xlUnderlineStyleNone .ColorIndex = xlAutomatic .Background = xlAutomatic End With End With ' Next j End Sub Sub shosikiLabel() Dim a As Integer For i = 1 To ActiveSheet.ChartObjects.Count a = MsgBox(i & "番目のグラフのラベル書式を設定します", vbOKCancel, "実行") If a = vbOK Then Set obj1 = ActiveSheet.ChartObjects.Item(i) Set chart1 = obj1.Chart Set collection1 = chart1.SeriesCollection For j = 1 To collection1.Count Set series1 = collection1.Item(j) series1.DataLabels.Select 'Selection.AutoScaleFont = True With Selection.Font .Name = "MS Pゴシック" .FontStyle = "太字" .Size = 8 .Strikethrough = False .Superscript = False .Subscript = False .OutlineFont = False .Shadow = False .Underline = xlUnderlineStyleNone .ColorIndex = xlAutomatic .Background = xlAutomatic End With ' Selection.NumberFormatLocal = "G/標準" Next j End If Next i End Sub