h-yonesanのblog

VBAやプログラムについて日々勉強したことを書いています。

折れ線グラフを散布図に変更して、軸の書式設定を行う PowerPointマクロ

先日PowerPointのスライド200枚の中にある折れ線グラフ約250個に対して、以下の作業をする機会があった。
手作業だと大変なので、Power Pointマクロを初めて書いてみた。

修正内容は以下の通り。
各折れ線グラフに対して
(1)グラフの種類を折れ線から散布図に変更
(2)横軸の最大値、最小値を設定

更に、一つのスライドに存在する折れ線グラフの数によって処理が異なり、
1つの場合
 目盛り幅を4に設定
2つ以上の場合
 目盛り幅を8に設定
 補助目盛り幅を4に設定
 補助目盛りの種類を目盛りと同じものに設定

Excel VBAAccess VBAと勝手が異なり、苦労したが、以下のようなコードに落ち着いた。
細かな処理は別プロシージャ化して、なるべくMainのプロシージャが簡潔になるようにした。
改善点は色々あると思うが、とりあえずやりたいことは出来たので、これでよしとしよう。

Sub Main()
    Dim s As slide
    Dim lineCharts As Collection, chart As Variant
    For Each s In ActivePresentation.Slides
        Set lineCharts = GetLineCharts(s) 
        For Each chart In lineCharts
            Call EditLineChart(chart, lineCharts.Count)
        Next chart
    Next s
End Sub

Sub EditLineChart(chart As Variant, chart_num As Long)
    Dim shp As Shape: Set shp = chart
    Dim xAxis As Axis: Set xAxis = shp.chart.Axes(1)
    shp.chart.ChartType = xlXYScatterLines
    xAxis.MinimumScale = 0
    xAxis.MaximumScale = 96
    If chart_num = 1 Then
        xAxis.MajorUnit = 4
    Else
        xAxis.MajorUnit = 8
        xAxis.MinorTickMark = xAxis.MajorTickMark
        xAxis.MinorUnit = 4
    End If
End Sub

Function GetLineCharts(s As slide) As Collection
    Dim ret As Collection: Set ret = New Collection
    Dim shp As Shape
    For Each shp In s.Shapes
        If shp.HasChart Then
            If shp.chart.ChartType = xlLineMarkers Then ret.Add shp 
        End If
    Next shp
    Set GetLineCharts = ret
End Function

VBA Functionプロシージャの実装の一例

いつも勉強させてもらっているこちらのサイトで、面白い記事があった。
「ByRef・参照渡しとはどう使うのか」
http://www.relief.jp/docs/vba-how-to-use-byref.html#extended

記事を参考にコードを書いてみた。

(1) コードの前半4桁と後半6桁を、配列で返す場合

Function GetSplitCode2(ByVal code As String) As String()
    Dim ret(1) As String
    ret(0) = Mid(code, 1, 4)
    ret(1) = Mid(code, 5, 6)
    GetSplitCode2 = ret
End Function

次に、整数値を入力してもらうように変更したのが次のコード。

(2)コードの前後半のどちらかを返す場合

Function GetSplitCode3(ByVal code As String, num As Long) As String
    Dim ret As String
    Select Case num
        Case 1: ret = Mid(code, 1, 4)
        Case 2: ret = Mid(code, 5, 6)
        Case Else: ret = "ERROR"
    End Select
    GetSplitCode3 = ret
End Function

なお、1,2以外が入力された場合は"ERROR"を返すようにした。
前半を1、後半を2、というのは分かりにくいな。。
実引数名が「num」というのもいまいちだが、、

イミディエイトウインドウでテストするとと下記のようになる

?GetSplitCode2("abcd012345")(0)
abcd
?GetSplitCode2("abcd012345")(1)
012345
?GetSplitCode3("abcd012345",1)
abcd
?GetSplitCode3("abcd012345",2)
012345
?GetSplitCode3("abcd012345",-10)
ERROR

Access VBA フォームのFilterプロパティに設定する文字列を生成する

初めに

先日、レコードを一覧表示するフォームに検索用のテキストボックスを追加し、その入力内容でフィルタをかける、という機能を作った。
例えばこんな感じ

Me.Filter= "入社年 > 2015 and 部署 = A事業部 and 性別 = 男"
Me.Fiter=True

このFilterプロパティに設定する文字列
"入社年 > 2015 and 部署 = A事業部 and 性別 = 男"
を生成する関数を作った。
(正確に言うと自分の力では作れず、私の先生の力を大いに借りたのだが、、)

コードの実装

Function Combine(condition1 As String, condition2 As String, condition3 As String) As String
    Combine = Join(Array(condition1, condition2, condition3), " and ")
End Function

これをイミディエイトウィンドウ上で実行すると
?combine("cond1","cond2","cond3")
cond1 and cond2 and cond3
となった。

今は引数の数が固定なので、任意の数の引数に対応するようにしたい。改良したのが次のコード。

Function Combine(ParamArray conditions()) As String
    Dim ret As String
    Dim i As Long
    For i = LBound(conditions) To UBound(conditions)
        ret = ret & " and " & conditions(i)
    Next i
    Combine = ret
End Function

これを実行すると
?combine("cond1","cond2")
and cond1 and cond2

?combine("cond1","cond2","cond3")
and cond1 and cond2 and cond3

と引数の数の変化には対応出来たが、先頭に" and "が入ってしまった。それを削除したのが次のコード

Function Combine(ParamArray conditions()) As String
    Dim ret As String
    Dim i As Long
    For i = LBound(conditions) To UBound(conditions)
        ret = ret & " and " & conditions(i)
    Next i
    Combine = Mid(ret, Len(" and ") + 1)
End Function

実行すると
?combine("cond1","cond2")
cond1 and cond2

?combine("cond1","cond2","cond3")
cond1 and cond2 and cond3

と先頭の" and "が削除された。更に区切り文字 " and "も引数にしたのが次のコード。

Function Combine(delimiter As String, ParamArray conditions()) As String
    Dim ret As String
    Dim i As Long
    For i = LBound(conditions) To UBound(conditions)
        ret = ret & delimiter & conditions(i)
    Next i
    Combine = Mid(ret, Len(delimiter) + 1)
End Function

実行すると
?combine(" and ","cond1","cond2","cond3")
cond1 and cond2 and cond3
となった。

ただし、今の関数だと引数が空文字列の場合
?combine(" and ","cond1","","cond3")
cond1 and and cond3
?combine(" and ","","cond2","cond3")
and cond2 and cond3

のように不要なandが含まれてしまう。引数に空文字列が与えられた場合(つまり検索条件の指定が無かった場合)スキップするように改良したのが次のコード

Function Combine(delimiter As String, ParamArray conditions()) As String
    Dim ret As String
    Dim i As Long
    For i = LBound(conditions) To UBound(conditions)
        If conditions(i) <> "" Then ret = ret & delimiter & conditions(i)
    Next i
    Combine = Mid(ret, Len(delimiter) + 1)
End Function

実行すると
?combine(" and ","cond1","","cond3")
cond1 and cond3
?combine(" and ","","cond2","cond3")
cond2 and cond3
と余計なandが入っていない。これで一応欲しい機能が実現出来たようだ。だが、きちんと動作確認するには単体テストが必要で、それは後日書こうと思う。

最後に

生まれて初めてブログを書いた。ブログを書くのがこんなに難しいとは思わなかった。文章を書く良い訓練になるので、今後も自分が勉強したことを少しずつ書いていこうと思う。
また、シンタックスハイライトが出来なくて困ったが、こちらの記事を見て解決した。ありがとうございます!
k01ken.hatenablog.com