EXCEL VBAで綺麗な波線を書く

EXCELで綺麗な波線を書きたい

波線が書きたいユーザーは多いと思うのですが、、
標準の曲線ではきれいな波線が書けないですよね。

ということで、区切り線や省略記号として、きれいな波線が書きたいと思って作りました。

作成される波線：

波線を書くにはVBAを使い、曲線の頂点を計算してやればいい！

曲線を作成、頂点を追加し、波線にするプログラムです。

使い方は簡単で、下記のコードをEXCEL VBAの標準モジュールファイルに張り付けて使ってください。

basShape.vb

Option Explicit

Private Const MIN_KUGIRI As Double = 10.125
Public shpTmp      As Shape

'機能説明   :波の作成（縦）
'引数　　   :
'戻り値　   :
'備考　　   :
Sub DrawWaveY()
On Error GoTo ErrDrawWaveY
    Dim rngTmp      As Range
    Dim dblKugiri   As Double
    Dim dblLeft     As Double
    Dim dblTop      As Double
    Dim i           As Integer
    Dim strWave     As String
    Dim dblWave     As Double
    Dim dblFugou    As Double

    If TypeName(Selection) <> "Range" Then
        Exit Sub
    End If

    Set rngTmp = Selection

    strWave = InputBox("波数", "入力", 1.5)
    If Not IsNumeric(strWave) Then
        Exit Sub
    End If
    dblWave = CDbl(strWave)

    dblLeft = rngTmp.Left
    dblTop = rngTmp.Top

    dblFugou = 1

    With ActiveSheet.Shapes.BuildFreeform(msoEditingAuto, dblLeft, dblTop)

        dblKugiri = rngTmp.Height / (dblWave * 2)
        If dblKugiri < MIN_KUGIRI Then
            dblKugiri = MIN_KUGIRI
        End If

        For i = 1 To (dblWave * 2)
            dblLeft = dblLeft + (rngTmp.Width * dblFugou)
            dblTop = dblTop + dblKugiri

            .AddNodes msoSegmentCurve, msoEditingAuto, dblLeft, dblTop

            dblFugou = dblFugou * -1
        Next i

        Set shpTmp = .ConvertToShape

    End With

    shpTmp.Select
    shpTmp.Height = rngTmp.Height
    shpTmp.Width = rngTmp.Width

    Application.OnUndo "Undo test", "UndoWave"

ErrDrawWaveY:
End Sub

'機能説明   :波の作成（横）
'引数　　   :
'戻り値　   :
'備考　　   :
Sub DrawWaveX()
On Error GoTo ErrDrawWaveX
    Dim rngTmp      As Range
    Dim dblKugiri   As Double
    Dim dblLeft     As Double
    Dim dblTop      As Double
    Dim i           As Integer
    Dim strWave     As String
    Dim dblWave     As Double
    Dim dblFugou    As Double

    If TypeName(Selection) <> "Range" Then
        Exit Sub
    End If

    Set rngTmp = Selection

    strWave = InputBox("波数", "入力", 1.5)
    If Not IsNumeric(strWave) Then
        Exit Sub
    End If
    dblWave = CDbl(strWave)

    dblLeft = rngTmp.Left
    dblTop = rngTmp.Top

    dblFugou = 1


    With ActiveSheet.Shapes.BuildFreeform(msoEditingAuto, dblLeft, dblTop)

        dblKugiri = rngTmp.Width / (dblWave * 2)
        If dblKugiri < MIN_KUGIRI Then
            dblKugiri = MIN_KUGIRI
        End If

        For i = 1 To (dblWave * 2)
            dblTop = dblTop + (rngTmp.Height * dblFugou)
            dblLeft = dblLeft + dblKugiri

            .AddNodes msoSegmentCurve, msoEditingAuto, dblLeft, dblTop

            dblFugou = dblFugou * -1
        Next i

        Set shpTmp = .ConvertToShape

    End With

    shpTmp.Select
    shpTmp.Height = rngTmp.Height
    shpTmp.Width = rngTmp.Width

    Application.OnUndo "Undo test", "UndoWave"
ErrDrawWaveX:
End Sub

使い方

• １．波線を記述する範囲のセルを選択します。
  

• ２．横長の選択範囲なので、DrawWaveXのマクロを実行

• ３．入力ダイアログが表示されますので、波の数を入力します。
  

• ４．波線が作成されます。
  

応用

波線を2本作成すると、図形などの省略線の作成などができます。