元データ

あるお店に蓄積された6年分の回収済みポイントカードの自由記入欄を解析し、前半3年・後半3年の2期に分けて頻出語（上位20語）を集計したデータです。シート名は「Source」で、左側が前半・右側が後半の集計結果です。

02

表を統合する

前半・後半の2つの表を1つに統合します。新しいシート「Consolidation」を挿入し、出力先のセル（A1 推奨）をアクティブにしておきます。

データタブ → データツールグループの統合をクリックします。

統合の設定ダイアログで集計の方法が合計になっていることを確認し、統合元範囲に「Source」シートの左側の表を指定して追加。同様に右側の表も追加します。

統合の基準の上端行・左端列両方にチェックを入れて OK。前半・後半の2つの表が1つに統合されます。

03

棒グラフと比べてみて見えてくること

2時点の量を比較する場合、まず思い浮かぶのは2色の棒グラフです。個別の要素を取り出す用途には向いていますが、「前半3位のワードが後半では何位か」「全体的に伸びたか減ったか」といった俯瞰的な問いには答えにくい構造です。

これをマーカー付き折れ線グラフに変えて行/列を切り替えると、両時点で順的秩序は保たれます。しかし今度は「どの線がどの要素か」がひどく識別しにくくなります。Tufte のスロープグラフはこの問題を、凡例に頼らず要素名と値を両端のラベルとして直接付置することで解消しています。

04

VBE を起動してコードをコピペする

リボンの開発タブ → コードグループの Visual Basic をクリックして VBE を起動します。メニューの挿入 → 標準モジュールでコードウィンドウを表示します。

下のコードをすべてコピーし、コードウィンドウに貼り付けます。VBE を閉じます。


Option Explicit
Option Base 1

'===============================================================================
' スロープグラフ 作成マクロ
' サイト     : hitorimarketing.net/tools/vba/slope-graph.html
' 作成者     : hawcas
' 作成年     : 2020
'===============================================================================
'
' 【概要】
'   2時点間の変化を線で結ぶスロープグラフを折れ線グラフベースで生成する。
'   片側の値が空白の系列はマーカーのみ（線なし）で表示し、
'   両側に値がある系列は実線で結ぶ。
'   各系列のデータラベルには「項目名 + 値」を連結したテキストを表示する。
'
' 【使い方】
'   1. 元データ（A 列: 項目名, B 列: 時点1の値, C 列: 時点2の値）を選択する。
'   2. DrawSlopeGraph_Main を実行する。
'
' 【新規シートへの書き出し（データラベル用）】
'   選択範囲の C 列から右 2 列目（E 列相当）: 系列番号（1〜size）
'   選択範囲の C 列から右 3 列目（F 列相当）: データラベル用テキスト（IF 数式）
'     左端ラベル: 「時点2の値 + スペース + 項目名」
'     右端ラベル: 「項目名 + スペース + 時点1の値」
'
' 【モジュール構成】
'   Public Sub
'     DrawSlopeGraph_Main     メイン処理（グラフ生成・系列スタイル設定）
'     DrawSlopeGraph_Sub1     データラベル用テキストの生成（ワークシート数式を配置）
'     DrawSlopeGraph_Sub2     データラベルの付加（InsertChartField でセル参照を設定）
'
'   Private Sub（内部ユーティリティ）
'     SetMarker   片側が空白の系列をマーカーのみ表示に設定する
'     FillLine    両側に値がある系列を実線表示に設定する
'===============================================================================


'===============================================================================
' Sub : DrawSlopeGraph_Main
' 概要 : メイン処理。
'        選択範囲を元に折れ線グラフを生成し、系列ごとに
'        「実線（FillLine）」または「マーカーのみ（SetMarker）」のスタイルを適用する。
'        その後 Sub1・Sub2 を呼んでデータラベルを追加する。
' 前提 : A 列: 項目名, B 列: 時点1の値, C 列: 時点2の値 の範囲を選択してから実行。
'        1行目はヘッダー行として扱う。
'===============================================================================
Sub DrawSlopeGraph_Main()

Dim target        ' 選択範囲オブジェクト
Dim x As Long, y As Long ' ループカウンタ

Set target = Selection

'--- 折れ線グラフを追加し、系列を行方向（各行 = 1 系列）に設定する ---
ActiveSheet.Shapes.AddChart(xlLine).Select
ActiveChart.PlotBy = xlRows

'--- 系列ごとにスタイルを振り分ける ---
'   B 列または C 列が空白の系列 → マーカーのみ（SetMarker）
'   両列に値がある系列         → 実線（FillLine）
For y = 2 To target.Rows.Count
    If target.Range("b1").Offset(y - 1, 0).Value = "" Or _
        target.Range("c1").Offset(y - 1, 0).Value = "" Then
        Call SetMarker(y)
    Else
        Call FillLine(y)
    End If
Next y

'--- データラベル用テキストの生成とラベルの付加 ---
Call DrawSlopeGraph_Sub1(target)
Call DrawSlopeGraph_Sub2(target)

End Sub


'===============================================================================
' Sub : DrawSlopeGraph_Sub1
' 概要 : データラベル用のテキストをワークシート数式として生成する。
'        系列数 × 2 行分のラベルテキストを選択範囲の右 3〜4 列目に配置する。
'        奇数行 = 左端ラベル（時点2の値 + 項目名）
'        偶数行 = 右端ラベル（項目名 + 時点1の値）
' 引数 : t - DrawSlopeGraph_Main の選択範囲（ByVal）
' 出力 : t.Range("c1").Offset(1, 2) 以降: 系列番号（連番）
'        t.Range("c1").Offset(1, 3) 以降: ラベルテキスト（IF 数式、AutoFill で展開）
'===============================================================================
Sub DrawSlopeGraph_Sub1(ByVal t)

Dim y    As Long
Dim size As Long
size = (t.Rows.Count - 1) * 2 ' ラベル行数 = 系列数 × 2（左端・右端で 1 系列あたり 2 行）

'--- 系列番号を連番で書き出す（DrawSlopeGraph_Sub2 の参照用）---
For y = 1 To size
    t.Range("c1").Offset(y, 2).Value = y
Next y

'--- ラベルテキスト数式を生成して AutoFill で全行に展開する ---
'   ROW() の偶奇でラベルの向き（左端・右端）を切り替える
'     偶数行: 「項目名 + " " + 時点1の値」→ グラフの右端ラベル
'     奇数行: 「時点2の値 + " " + 項目名」→ グラフの左端ラベル
Dim str As String
str = "=IF(MOD(ROW(),2)=0, " & _
    "CONCATENATE(OFFSET($A$1,INT(ROW()/2),0), " & _
    """ "", OFFSET($B$1,INT(ROW()/2),0)), " & _
    "CONCATENATE(OFFSET($C$1,INT(ROW()/2),0), " & _
    """ "", OFFSET($A$1,INT(ROW()/2),0)))"
With t.Range("c1").Offset(1, 3)
    .Formula = str
    .AutoFill Destination:=Range(t.Range("c1").Offset(1, 3), _
        t.Range("c1").Offset(size, 3))
End With

End Sub


'===============================================================================
' Sub : DrawSlopeGraph_Sub2
' 概要 : 各系列にデータラベルを付加し、Sub1 が生成したテキストをセル参照で連動させる。
'        左端ラベルは xlLabelPositionLeft に固定する。
'        フォントサイズ・フォント名は本 Sub 内で直接変更できる。
' 引数 : t - DrawSlopeGraph_Main の選択範囲（ByVal）
'===============================================================================
Sub DrawSlopeGraph_Sub2(ByVal t)

Dim y
Dim size As Long
Dim gObj As ChartObject

Set gObj = ActiveChart.Parent
size = (t.Rows.Count - 1) * 2

Dim cnt As Long  ' 系列インデックス（1 〜 系列数）
Dim str As String

'--- 各系列にラベルテキスト（2行分のセル参照）を InsertChartField で設定する ---
'   Step 2 で奇数行・偶数行をペアとして 1 系列に対応させる
For y = 1 To size Step 2
    cnt = Application.WorksheetFunction.RoundUp(y / 2, 0) ' 系列番号（1 始まり）
    str = "='" & ActiveSheet.Name & "'!" & _
        t.Range("c1").Offset(y, 3).Address & ":" & _
        t.Range("c1").Offset(y + 1, 3).Address ' 奇数行（左端）〜偶数行（右端）のセル範囲

    With gObj.Chart.SeriesCollection(cnt)
        .HasDataLabels = True
        With .DataLabels
            .Format.TextFrame2.TextRange. _
                InsertChartField msoChartFieldRange, str, 0 ' セル参照をラベルに設定
            .ShowValue = False  ' 数値ラベルを非表示（セル参照テキストのみ表示）
            .ShowRange = True
            .Format.TextFrame2.WordWrap = msoFalse ' 折り返しなし
        End With
    End With

    '--- フォントの設定（サイズ・日本語フォント・欧文フォントを変更する場合はここを編集）---
    With gObj.Chart.SeriesCollection(cnt).DataLabels. _
        Format.TextFrame2.TextRange.Font
        .size       = 9
        .NameFarEast = "BIZ UDゴシック" ' 日本語フォント
        .Name        = "Myriad Pro"      ' 欧文フォント
    End With

Next y

'--- 各系列の左端点ラベルを左揃えに設定する ---
size = t.Rows.Count - 1
For y = 1 To size
    gObj.Chart.SeriesCollection(y).Points(1).DataLabel.Position = xlLabelPositionLeft
    ' ラベルの自動サイズ調整を無効にする場合はコメント解除:
    'gObj.Chart.SeriesCollection(y).DataLabels.Format.TextFrame2.AutoSize = msoAutoSizeNone
Next y

End Sub


'===============================================================================
' Sub : SetMarker  [Private]
' 概要 : 指定系列を「マーカーのみ・線なし」に設定する。
'        B 列または C 列が空白で片側の値しかない系列に適用する。
' 引数 : i - 系列番号（FullSeriesCollection のインデックス; Main の y 値と対応）
' 設定値（変更する場合はここを編集）:
'   MarkerStyle : xlMarkerStyleDot（点）/ xlMarkerStyleCircle（円形）
'   MarkerSize  : マーカーのサイズ（pt）
'   ForeColor   : マーカーの塗りつぶし色（RGB）
'===============================================================================
Private Sub SetMarker(ByVal i As Long)
With ActiveChart.FullSeriesCollection(i - 1)
    .ChartType               = xlLineMarkers
    .MarkerStyle             = xlMarkerStyleDot ' 変更例: xlMarkerStyleCircle（円形）
    .MarkerSize              = 5
    .Format.Fill.ForeColor.RGB = RGB(0, 0, 0)  ' マーカーの色
    .Format.Line.Visible     = msoFalse         ' 線を非表示
End With
End Sub


'===============================================================================
' Sub : FillLine  [Private]
' 概要 : 指定系列を「実線・マーカーなし」に設定する。
'        B・C 列の両方に値がある系列に適用する。
' 引数 : i - 系列番号（FullSeriesCollection のインデックス; Main の y 値と対応）
' 設定値（変更する場合はここを編集）:
'   ForeColor : 線の色（RGB）
'   Weight    : 線の太さ（pt）
'===============================================================================
Private Sub FillLine(ByVal i As Long)
With ActiveChart.FullSeriesCollection(i - 1).Format.Line
    .ForeColor.RGB = RGB(0, 0, 0) ' 線の色
    .Weight        = 1             ' 線の太さ（pt）
End With
End Sub