Excelの色付きセルで表現したガントチャートを図形に自動変換するマクロ

とってもマイナーな話題で申し訳ない。
Excelを使って、作業日程の管理のためにガントチャートを作るというのは、よくある話だ。
そのとき、図形(長方形)でガントチャートのバーを描く人と、シートの列幅を狭くして、セルに色を塗ってガントチャートのバーを描く人の、2種類に分かれるだろう。
もしそのガントチャートで、1週間、1か月などの期間の区切りを、セルの罫線を使って表現している場合、セルに色を塗ってバーを描く「セル派」の人は、やや面倒なことになる。
大幅な日程の組み換えがおこったとき、いちいちセルの色を一つひとつ、無色にしたり、色をつけたりする地道な作業が発生するからだ。
というのは、セルの書式を一括して変更しようとすると、罫線まで変更されてしまう。期間の区切りを表現する罫線を残したまま、セルの色だけを一つひとつ変更していくのは、やや面倒な作業だ。
そういう場合は、最初から図形(長方形)でバーを描いておいた方が、はるかに楽である。マウスでドラッグ&ドロップして、バーの長さを伸ばしたり縮めたりするだけで、大幅な日程の組み換えにも対応できるからだ。
※もちろんMicrosoft Office Project Professionalがあれば、最初からそれを使って日程計画を立てるのが最適な方法だが。
そこで、「セル派」の人が作成したガントチャートを、自動的に図形に描き換えるマクロを考えてみる。
要は、同じ行にある、連続する色付きのセルを、1個の図形(長方形)に変換するマクロだ。
最初に、ガントチャートのあるExcelのWorksheetオブジェクトを、あらかじめxSheetという変数に代入しておくとする。(以下、Excel 2007を前提とするがExcel 2003でも動くはず)

Set xSheet = Thisworkbook.Sheets(“[ガントチャートのあるシート名]”)

あるセルに色がついているかどうかの判別はかんたんだ。
Rangeオブジェクト(Cellオブジェクト)のInterior.Pattern属性が xlNone なら色なし、xlNone以外なら、何らかの色がついていることになる。

If xSheet.Cells(行数, 列数).Interior.Pattern <> xlNone Then
     ‘ ここに色付きセルの場合の処理の内容
End If

ただ、「連続する色付きのセル」という部分の自動判別は、やや面倒だ。
各行のセルを、いちばん左のA列から右へ1つずつ調べていくが、そのとき、直前のセルを変数に保持しておく。
(A)現在のセルに色があれば、「連続する○○色のセル地帯に突入しました!」という意味のBoolean型の変数にTrueを代入する。
このBoolean型の変数名を bInProcess と名づけておく。
(B)現在のセルに色がないか、現在のセルと直前のセルの色が違う場合は、「連続する○○色のセル地帯から抜け出しました!」という意味でbInProcessにFalseを代入する。
ミソは、上述の二つのIf文を、(B)(A)の順に記述する点だ。
そうすると、色付きという意味では連続しているが、途中で色が切り替わる場合も、正確に図形(長方形)に変換できる。
次に連続するセルの左端と右端、上下の高さに、図形(長方形)の大きさをきっちり合わせる方法だが、これは比較的かんたん。
仮に開始位置のセルオブジェクトを、xStartCellという変数に代入し、
終了位置のセルオブジェクトを、xEndCellという変数に代入したとする。
連続するセルの左端は、xStartCell.Left
連続するセルの幅は、xEndCell.Left + xEndCell.Width – xStartCell.Left
連続するセルの上端は、xStartCell.Top(xEndCell.Topでも同じこと)
連続するセルの高さは、xStartCell.Height(xEndCell.Heightでも同じこと)
この4つの数値が分かれば、あとは次のようにすれば、連続する色付きセルときっちり位置を合わせた長方形を描画できる。(描画した長方形オブジェクトは xShape という変数に代入するとする)

Set xShape = xSheet.Shapes.AddShape(msoShapeRectangle, 左端, 上端, 幅, 高さ)

セルの位置と図形の位置との間では、単位変換の必要はない。そのままの値が使えるので便利だ。
次に、いま描画した長方形に、開始位置のセルと同じ色を塗る。そのとき、図形のFill.ForeColor属性にある、RGB属性を利用するのがミソだ。

xShape.Fill.ForeColor.RGB = xStartCell.Interior.Color

このように図形のRGB属性に対して、セルの内部色を代入しないと、エラーになるので要注意だ。
さらに、期間をあらわす罫線が透けて見えるようにするために、いま描画した長方形を半透明にしよう。

xShape.Fill.Transparency = 0.3

Transparencyは「1」にすると透明、「0」にすると完全に不透明になる。0~1の間で好みによって設定するとよい。
さて、さらに開始位置のセルに入力されていた文字列(たぶんタスク名など)を、この図形上に表示させたいというニーズがあるかもしれない。
残念ながら、図形内に文字列を書き込んだとき、その文字列を図形からはみ出させる設定は、僕が調べた限りでは、マクロ(Visual Basic for Application)では不可能だ。
文字列を図形内部で折り返すか、図形の方を文字列の長さに合わせて自動で大きくなるようにするか、このどちらかしかできない。
ガントチャートのような場合、このどちらも不都合だ。
そのため、ガントチャートのバーを表す長方形の上に、さらに透明な長方形を重ねて、そちらの方に文字列を書き込み、文字列の長さに合わせてサイズを自動変更する設定にするしかない。
文字列を書き込む方の長方形オブジェクトを、仮にxTextBoxという変数に代入するとすると。

Set xTextBox = xSheet.Shapes.AddShape(msoShapeRectangle, 左端 + 6, 上端, 幅, 高さ)

となる。左端にわざわざ「6」を足しているのは、後からマウスでクリックするときに、先ほど描画したバーに対して、少しだけ左にずらしておいた方がクリックしやすいためだ。
文字列を書き込む長方形オブジェクトは、完全に透明にしたいので、下記のように設定する。

xTextBox.Line.Transparency = 1 ‘ 外枠線は完全に透明
xTextBox.Fill.Transparency = 1 ‘ 塗りつぶしは完全に透明

後は、開始位置のセルに入力されていた文字列を、そのままこの完全に透明な長方形内部に記入する。
ここでのポイントは、xTextBoxオブジェクトのTextEffect属性を利用することだ。

With xTextBox.TextEffect
    .Alignment = msoTextEffectAlignmentLeft
    .FontName = “MS UI Gothic”
    .FontSize = 10
    .FontBold = msoTrue
    .Text = xStartCell.Text
End With
xTextBox.TextFrame.AutoSize = True

Alignment属性では、文字列を左詰にしてある。FontNameやFontSize、FontBoldあたりは、好みに合わせて変更して頂きたい。
xTextBox.TextEffect.Text = xStartCell.Text とすれば、セルに入力された文字列を、そのまま図形(長方形)内部に自動転記できる。
最後に xTextBox.TextFrame.AutoSize = True としているのは、文字列に合わせて、この完全に透明な長方形のサイズを自動的に拡張するためだ。
こうして色付きセルを図形化したら、最後の最後に、もともとの色付きセルの色を消してしまおう。

xSheet.Range(xStartCell, xEndCell).Interior.Pattern = xlNone
xSheet.Range(xStartCell, xEndCell).Value = “”

連続するセルの Interior.Pattern属性 に xlNone を代入してしまえば、セルの色が消える。
また、連続するセルの Value 属性に空文字列を代入してしまえば、セルの中身の文字列もすべて消える。
以上のような考え方でマクロを記述すれば、たとえば下記のようになる。
なお、変換するセルの開始位置、終了位置は、冒頭にグローバル定数としてハードコーディングしている。
また、対象となるワークシートも、面倒なのでグローバル変数にしてしまっている。本来ならMainルーチンからサブルーチンへ参照渡しすべきだけれど。

Option Explicit
Const START_ROW = 1
Const END_ROW = 200
Const START_COL = 1
Const END_COL = 100
Dim xSheet As Worksheet
Sub Main()
    Dim iRow As Integer
    Dim iCol As Integer
    
    Dim xCurCell As Range
    Dim xPreCell As Range
    Dim bInProcess As Boolean
    
    Dim xStartCell As Range
    Dim xEndCell As Range
    
    Dim xShape As Shape
    Set xSheet = ThisWorkbook.Sheets(1)
    xSheet.Activate
    For iRow = START_ROW To END_ROW
    
        bInProcess = False
    
        For iCol = START_COL To END_COL
            Set xCurCell = xSheet.Cells(iRow, iCol)
            
            ‘ 以下の2つのIf文の順序は変えないこと
            ‘ (異なる色のセルが連続している場合に正しく長方形に変換できなくなるため)
            
            If bInProcess Then
                If xCurCell.Interior.Pattern = xlNone Or _
                xCurCell.Interior.Color <> xPreCell.Interior.Color Or _
                xCurCell.Interior.Pattern <> xPreCell.Interior.Pattern Then
                    xCurCell.Select
                    Set xEndCell = xPreCell
                    Call AddRectangle(xStartCell, xEndCell)
                    bInProcess = False
                End If
            End If
            
            If Not bInProcess Then
                If xCurCell.Interior.Pattern <> xlNone Then
                    Set xStartCell = xCurCell
                    bInProcess = True
                End If
            End If
            
            Set xPreCell = xCurCell
            
        Next
        
    Next
End Sub
Sub AddRectangle(xStartCell As Range, xEndCell As Range)
    Dim xShape As Shape
    Dim xTextBox As Shape
    Dim iTop As Integer
    Dim iLeft As Integer
    Dim iWidth As Integer
    Dim iHeight As Integer
    
    iLeft = xStartCell.Left
    iTop = xStartCell.Top
    iWidth = xEndCell.Left + xEndCell.Width – xStartCell.Left
    iHeight = xStartCell.Height
    
    Set xShape = xSheet.Shapes.AddShape(msoShapeRectangle, iLeft, iTop, iWidth, iHeight)
    
    With xShape.Fill
        .ForeColor.RGB = xStartCell.Interior.Color
        .Transparency = 0.3
    End With
    
    If xStartCell.Text = “” Then Exit Sub
    
    ‘ 長方形の少し右にずらして描画する
    Set xTextBox = xSheet.Shapes.AddShape(msoShapeRectangle, iLeft + 6, iTop, iWidth, iHeight)
        
    xTextBox.Line.Transparency = 1 ‘ 外枠線は完全に透明
    xTextBox.Fill.Transparency = 1 ‘ 塗りつぶしは完全に透明
    
    With xTextBox.TextEffect
        .Alignment = msoTextEffectAlignmentLeft
        .FontName = “MS UI Gothic”
        .FontSize = 10
        .FontBold = msoTrue
        .Text = xStartCell.Text
    End With
    
    xTextBox.TextFrame.AutoSize = True
    
    Call xTextBox.ZOrder(msoSendToBack)
    Call xShape.ZOrder(msoSendToBack)
    ‘ もともとのセルの色と文字列をクリアしてしまう
    xSheet.Range(xStartCell, xEndCell).Interior.Pattern = xlNone
    xSheet.Range(xStartCell, xEndCell).Value = “”
    
End Sub