ラベル ExcelVBA の投稿を表示しています。 すべての投稿を表示
ラベル ExcelVBA の投稿を表示しています。 すべての投稿を表示

2013年1月5日土曜日

[ExcelVBA] 正規表現(まとめ)


正規表現とは、文字列の集合を一つの文字列で表現する方法の一つである。正則表現とも呼ばれ、形式言語理論の分野では比較的こちらの訳語の方が使われる。まれに正規式と呼ばれることもある。

正規表現のまとめをのっけときます。


■正規表現まず最初に・・・
Set オブジェクト1 = CreateObject("VBScript.RegExp")

オブジェクト1.Pattern = "正規表現"
オブジェクト1.IgnoreCase = (True|False) 'T:大文字小文字区別しない、F:区別する(デフォルト)
オブジェクト1.Global = (True|False) 'T:繰返しマッチする、F:繰返しマッチしない(デフォルト)


オブジェクト1.Test("検査文字列") '結果を(True|False)で返す
Set オブジェクト2 = オブジェクト1.Execute("検査文字列") '結果をオブジェクトで返す

オブジェクト2.Count 'マッチした数を返す< オブジェクト2.Item(?).FirstIndex '何文字目にマッチしたか返す(最初の文字は0) オブジェクト2.Item(?).Length 'マッチした文字数 オブジェクト2.Item(?).Value 'マッチした文字列 オブジェクト2.Item(?).SubMatches.Count 'マッチした文字列のうち()部分の数 オブジェクト2.Item(?).SubMatches.Item(??) '()内でマッチした文字列 ・さんぷるこーど
Sub SampleCode()
Dim Reg As Object, result As Object
Set Reg = CreateObject("VBScript.RegExp")

Reg.Pattern = "〒((\d{3})-(\d{4}))" '正規表現セット

Set result = Reg.Execute("〒123-4567") '検査する文字列
Dim x As Integer, y As Integer
If 0 < result.Count Then Debug.Print "マッチした数  :" & result.Count Debug.Print "" For x = 0 To result.Count - 1 Debug.Print "何文字目にマッチ:" & result.Item(x).FirstIndex Debug.Print "マッチの文字数 :" & result.Item(x).Length Debug.Print "マッチした文字列:" & result.Item(x).Value Debug.Print "()でヒットした数:" & result.Item(x).Submatches.Count If 0 < result.Item(x).Submatches.Count Then '()内でマッチした内容を表示 For y = 0 To result.Item(x).Submatches.Count - 1 Debug.Print result.Item(x).Submatches.Item(y) Next End If Next End If Debug.Print "---" End Sub

実行結果---
マッチした数  :1

何文字目にマッチ:0
マッチの文字数 :9
マッチした文字列:〒123-4567
()でヒットした数:3
123-4567
123
4567
---


■メタ文字一覧
メタ文字意味
.任意の一文字
[(文字列)][]内の任意の一文字
[^(文字列)][]内の文字列以外の任意の一文字。
[0-9]0~9のうち任意の一文字、[2-7]なら2~7の任意の一文字
\d0~9のうち任意の一文字。[0-9]は\dと同義
\D0~9以外の任意の一文字。[^0-9]。\d以外が\D
[a-zA-Z]任意のアルファベット一文字
\w[a-zA-Z_0-9]と同義
\W\w以外。[^a-zA-Z_0-9]。
\s空白文字(半角スペース,タブ,改行)の任意の一文字
\s空白文字(半角スペース,タブ,改行)以外の任意の一文字
\メタ文字をエスケープする
*0回以上繰り返す
+1回以上繰り返す
{m}m回繰り返す
{m,}m回以上繰り返す
{m,n}m回以上、n回以下繰り返す
?0回か1回繰り返す
||の前後のどちらかにマッチするか調べる
()グループ化および()内でマッチした内容を記憶する
(?:)()内でマッチした内容を記憶させない

[ExcelVBA] 正規表現


正規表現とは、文字列の集合を一つの文字列で表現する方法の一つである。正則表現とも呼ばれ、形式言語理論の分野では比較的こちらの訳語の方が使われる。まれに正規式と呼ばれることもある。


知らない人には、何のこと?って感じでしょうが
文字列操作をする上で欠かせない物の一つでしょうね。

例えば、以下の5つの文章が配列にはいっていたとしましょう。
こんな感じです。
Dim List(2) as string
    List(0) = "最初のテストは国語で、9:00~10:30"
    List(1) = "2番目のテストは算数で、10:30~12:00"
    List(2) = "3番目のテストは理科で、13:00~14:30"

と、なっていた時、各要素の中から時間を抜き出しなさい。
と言われたらどうします?
まさか、0:00~23:59の1440通り作ってそれぞれマッチするかテストします?
さすがに、それは無茶な話しですよねぇ 汗


日本語で時間を表現するのであれば…
1文字目がない時は、2文字目が0-9、3文字目はコロン、4文字目が0-5、5文字目が0-9
1文字目が1の時は、2文字目が0-9、3文字目はコロン、4文字目が0-5、5文字目が0-9
1文字目が2の時は、2文字目が0-3、3文字目はコロン、4文字目が0-5、5文字目が0-9
と表現できます。

これを正規表現で表現するなら
(1?\d|2[0-3]):[0-5]\d
これすみます。
少ない文字列で大量の文字パターンを表現することが
できるというのが正規表現の醍醐味でしょうね。


たとえば、アルファベット26文字は、[a-z]で表現できます。
数字0~9は、[0-9]だったり\dで表現できます。
数字10桁は、\d{10}で全通り表現できます。



そんなこんなで正規表現についていろいろメモ書きしていきます。
最初は、正規表現の必要がないものばかりですが、
理解しやすさを優先しての結果ですのでご了承願います。


■ExcelVBAで正規表現(お決まりのお話)

ExcelVBA単体では正規表現を利用することができません。
そこで、VBScriptの力を借りることになります。
一般的に、IE5以上が入っていればExcelVBAからでも利用可能です。
なんて話しがありますが昨今のPCなら全く問題ないでしょうねぇ。

では、正規表現を利用するにあたって…

Dim Reg As Object
Set Reg = CreateObject("VBScript.RegExp")

と書くことが正規表現を使う第一歩となります。
ここからは、コードを通して使い方になれてみましょう。


■マッチするかしないか判断する。

"abcde"の中に"bc"があるかないかだけを調べるコードです。

Sub SampleCode1()
    Dim Reg As Object
    Set Reg = CreateObject("VBScript.RegExp")

    Reg.Pattern = "bc" '正規表現セット    
    If Reg.Test("abcde") Then Debug.Print "match!"  'マッチする
    Debug.Print "---"
End Sub


■メタ文字を使ってマッチするか判断する

メタ文字とは、文字そのものの意味とは別の役割をもった文字のことです。
メタ文字意味
.任意の一文字
[(文字列)][]内の任意の一文字
[^(文字列)][]内の文字列以外の任意の一文字。
[0-9]0~9のうち任意の一文字、[2-7]なら2~7の任意の一文字
\d0~9のうち任意の一文字。[0-9]は\dと同義
\D0~9以外の任意の一文字。[^0-9]。\d以外が\D
[a-zA-Z]任意のアルファベット一文字
\w[a-zA-Z_0-9]と同義
\W\w以外。[^a-zA-Z_0-9]。
\s空白文字(半角スペース,タブ,改行)の任意の一文字
\s空白文字(半角スペース,タブ,改行)以外の任意の一文字
\メタ文字をエスケープする


<.⇒任意の一文字にマッチ>
Sub SampleCode2()
    Dim Reg As Object
    Set Reg = CreateObject("VBScript.RegExp")

    Reg.Pattern = "あん." '正規表現セット    
    If Reg.Test("あんい") Then Debug.Print "あんい:match!"  'マッチする
    If Reg.Test("あんき") Then Debug.Print "あんき:match!"  'マッチする
    If Reg.Test("あん♪") Then Debug.Print "あん♪:match!"  'マッチする
    Debug.Print "---"
End Sub


<[(文字列)]⇒[]内の任意の一文字にマッチ>
Sub SampleCode3()
    Dim Reg As Object
    Set Reg = CreateObject("VBScript.RegExp")

    Reg.Pattern = "あん[いき♪]" '正規表現セット    
    If Reg.Test("あんい") Then Debug.Print "あんい:match!"  'マッチする
    If Reg.Test("あんこ") Then Debug.Print "あんこ:match!"  'マッチしない
    If Reg.Test("あんき") Then Debug.Print "あんき:match!"  'マッチする
    If Reg.Test("あんま") Then Debug.Print "あんま:match!"  'マッチしない
    If Reg.Test("あん♪") Then Debug.Print "あん♪:match!"  'マッチする
    Debug.Print "---"
End Sub

正規表現が:あん[いき♪] の場合、
「あ」と「ん」と[]内の文字のどれかをあわせた3文字が一致した時にマッチとなります。
つまり、下記の3文字とマッチした時です。
あんい
あんき
あん♪


<[^(文字列)]⇒[]内の文字列以外の任意の一文字にマッチ>
Sub SampleCode4()
    Dim Reg As Object
    Set Reg = CreateObject("VBScript.RegExp")

    Reg.Pattern = "あん[^いき♪]" '正規表現セット
    If Reg.Test("あんい") Then Debug.Print "あんい:match!"  'マッチしない
    If Reg.Test("あんこ") Then Debug.Print "あんこ:match!"  'マッチする
    If Reg.Test("あんき") Then Debug.Print "あんき:match!"  'マッチししない
    If Reg.Test("あんま") Then Debug.Print "あんま:match!"  'マッチする
    If Reg.Test("あん♪") Then Debug.Print "あん♪:match!"  'マッチしない
    If Reg.Test("あん") Then Debug.Print "あん:match!"      'マッチしない
    Debug.Print "---"
End Sub
正規表現が:あん[^いき♪] の場合、
「あ」と「ん」と[]内の文字以外の3文字の時にマッチします


<[0-9]⇒0~9のうち任意の一文字にマッチ>
Sub SampleCode5()
    Dim Reg As Object
    Set Reg = CreateObject("VBScript.RegExp")

    Reg.Pattern = "[0-9]" '正規表現セット    
    If Reg.Test("WindowsXP") Then Debug.Print "WindowsXP:match!"      'マッチしない
    If Reg.Test("Windows2000") Then Debug.Print "Windows2000:match!"  'マッチする
    Debug.Print "---"

    Reg.Pattern = "[5-8]" '正規表現セット
    If Reg.Test("Windows2000") Then Debug.Print "Windows2000:match!"  'マッチしない
    If Reg.Test("消費税5%") Then Debug.Print "消費税5%:match!"        'マッチする
    Debug.Print "---"
End Sub
[0123456789]と[0-9]は同義です。括弧内の文字列のうちどれか一つでも含んでいるとマッチになります。
2つ目の例である、[5-8]は[5678]と同義のため、5か6か7か8が一つでも含んでいるとマッチになります。


<[a-zA-Z]⇒任任意のアルファベット一文字にマッチ>
Sub SampleCode6()
    Dim Reg As Object
    Set Reg = CreateObject("VBScript.RegExp")
    Reg.Pattern = "[a-z]" '正規表現セット
    If Reg.Test("Windows2000") Then Debug.Print "Windows2000:match!"  'マッチする
    If Reg.Test("EXCELVBA") Then Debug.Print "EXCELVBA:match!"        'マッチしない
    If Reg.Test("消費税5%") Then Debug.Print "消費税5%:match!"        'マッチしない
    Debug.Print "---"
End Sub
上の例は、小文字のアルファベットが一文字含んでいるときにマッチとなる例です。
よって、EXCELVBAは大文字のアルファベットなのでマッチしていません。


<\d,\D,\w,\W⇒数字、数字以外、アルファベットと_、アルファベットと_以外の一文字にマッチ>
Sub SampleCode7()
    Dim Reg As Object
    Set Reg = CreateObject("VBScript.RegExp")
    Reg.Pattern = "\d" '正規表現セット 数字一文字にマッチ
    If Reg.Test("Windows2000") Then Debug.Print "Windows2000:match!"  '「2」にマッチする
    If Reg.Test("EXCELVBA") Then Debug.Print "EXCELVBA:match!"        'マッチしない
    If Reg.Test("消費税5%") Then Debug.Print "消費税5%:match!"        '「5」にマッチする
    If Reg.Test("正規表現") Then Debug.Print "正規表現:match!"        'マッチしない
    Debug.Print "---"
    
    Reg.Pattern = "\D" '正規表現セット 数字以外の一文字にマッチ
    If Reg.Test("Windows2000") Then Debug.Print "Windows2000:match!"  '「W」にマッチする
    If Reg.Test("EXCELVBA") Then Debug.Print "EXCELVBA:match!"        '「E」にマッチする
    If Reg.Test("消費税5%") Then Debug.Print "消費税5%:match!"        '「消」にマッチする
    If Reg.Test("正規表現") Then Debug.Print "正規表現:match!"        '「正」マッチする
    Debug.Print "---"

    Reg.Pattern = "\w" '正規表現セット アルファベットと_一文字にマッチ
    If Reg.Test("Windows2000") Then Debug.Print "Windows2000:match!"  '「W」にマッチする
    If Reg.Test("EXCELVBA") Then Debug.Print "EXCELVBA:match!"        '「E」にマッチする
    If Reg.Test("消費税5%") Then Debug.Print "消費税5%:match!"        '「5」にマッチする
    If Reg.Test("正規表現") Then Debug.Print "正規表現:match!"        'マッチしない
    Debug.Print "---"

    Reg.Pattern = "\W" '正規表現セット アルファベットと_以外一文字にマッチ
    If Reg.Test("Windows2000") Then Debug.Print "Windows2000:match!"  'マッチしない
    If Reg.Test("EXCELVBA") Then Debug.Print "EXCELVBA:match!"        'マッチしない
    If Reg.Test("消費税5%") Then Debug.Print "消費税5%:match!"        '「消」にマッチする
    If Reg.Test("正規表現") Then Debug.Print "正規表現:match!"        '「正」にマッチする
    Debug.Print "---"
End Sub


<\s,\S⇒空白文字(半角スペース,タブ,改行)またはそれ以外の任意の一文字にマッチ>
Sub SampleCode8()
    Dim Reg As Object
    Set Reg = CreateObject("VBScript.RegExp")
    
    Reg.Pattern = "\s" '正規表現セット
    If Reg.Test("半角スペース:| |") Then Debug.Print "半角スペース:match!"   'マッチする
    If Reg.Test("全角スペース:| |") Then Debug.Print "全角スペース:match!"  'マッチしない
    If Reg.Test("タブ:|    |") Then Debug.Print "タブ:match!"                'マッチする
    If Reg.Test("タブ:|" & vbTab & "|") Then Debug.Print "タブ:match!"       'マッチする
    If Reg.Test("改行:|" & vbCrLf & "|") Then Debug.Print "CrLf:match!"      'マッチする
    If Reg.Test("改行:|" & vbCr & "|") Then Debug.Print "Cr:match!"          'マッチする
    If Reg.Test("改行:|" & vbLf & "|") Then Debug.Print "Lf:match!"          'マッチする
    Debug.Print "---"
End Sub
全角スペースにはマッチしないことだけは注意ですかね。
\Sを指定した場合は、上記以外の条件でマッチします。


<\⇒メタ文字をエスケープする>
Sub SampleCode9()
    Dim Reg As Object
    Set Reg = CreateObject("VBScript.RegExp")
    
    Reg.Pattern = "\d" '正規表現セット
    If Reg.Test("\d") Then Debug.Print "\d:match!"  'マッチしない
    
    Reg.Pattern = "\\d" '正規表現セット
    If Reg.Test("\d") Then Debug.Print "\d:match!"  'マッチする
    
    Reg.Pattern = "x{2}"
    If Reg.Test("x{2}") Then Debug.Print "x{2}:match!"  'マッチしない
    
    Reg.Pattern = "x\{2}"
    If Reg.Test("x{2}") Then Debug.Print "x{2}:match!"  'マッチする
    
    Debug.Print "---"
End Sub
メタ文字を本来の文字としてマッチさせる為には、メタ文字の前に\をおけばよいです。
.の前、[の前、{の前、\の前ですね、"の前、
そして、後で触れる^の前、$の前、(の前



■繰返し表現を使ってマッチするか判断する

メタ文字意味
*0回以上繰り返す
+1回以上繰り返す
{m}m回繰り返す
{m,}m回以上繰り返す
{m,n}m回以上、n回以下繰り返す
?0回か1回繰り返す


<*⇒0回以上繰り返す場合にマッチ>
Sub SampleCode10()
    Dim Reg As Object
    Set Reg = CreateObject("VBScript.RegExp")
    
    Reg.Pattern = "go*gle" '正規表現セット oはなくても一つ以上続いてもマッチ
    If Reg.Test("ggle") Then Debug.Print "ggle:match!"          'マッチする
    If Reg.Test("gogle") Then Debug.Print "gogle:match!"        'マッチする
    If Reg.Test("google") Then Debug.Print "google:match!"      'マッチする
    If Reg.Test("goooogle") Then Debug.Print "goooogle:match!"  'マッチする
    Debug.Print "---"
End Sub
正規表現:go*gle の場合
メタ文字の*の前の文字「o」は、無くてもいくつ続いてもマッチします。


<+⇒1回以上繰り返す場合にマッチ>
Sub SampleCode11()
    Dim Reg As Object
    Set Reg = CreateObject("VBScript.RegExp")
    
    Reg.Pattern = "go+gle" '正規表現セット oが1つ以上ある時にマッチ
    If Reg.Test("ggle") Then Debug.Print "ggle:match!"          'マッチしない
    If Reg.Test("gogle") Then Debug.Print "gogle:match!"        'マッチする
    If Reg.Test("google") Then Debug.Print "google:match!"      'マッチする
    If Reg.Test("goooogle") Then Debug.Print "goooogle:match!"  'マッチする
    Debug.Print "---"
End Sub
正規表現:go+gle の場合
メタ文字の+の前の文字「o」は、一つ以上繰り返す場合にマッチします。


<{m}⇒m回繰り返す場合にマッチ>
Sub SampleCode12()
    Dim Reg As Object
    Set Reg = CreateObject("VBScript.RegExp")
    
    Reg.Pattern = "go{1}gle" '正規表現セット oが1回続く時にマッチ
    If Reg.Test("ggle") Then Debug.Print "ggle:match!"          'マッチしない
    If Reg.Test("gogle") Then Debug.Print "gogle:match!"        'マッチする
    If Reg.Test("google") Then Debug.Print "google:match!"      'マッチしない
    If Reg.Test("goooogle") Then Debug.Print "goooogle:match!"  'マッチしない
    Debug.Print "---"
End Sub


<{m,}⇒m回以上繰り返す場合にマッチ>
Sub SampleCode13()
    Dim Reg As Object
    Set Reg = CreateObject("VBScript.RegExp")
    
    Reg.Pattern = "go{1,}gle" '正規表現セット oが1回以上続く時にマッチ
    If Reg.Test("ggle") Then Debug.Print "ggle:match!"          'マッチしない
    If Reg.Test("gogle") Then Debug.Print "gogle:match!"        'マッチする
    If Reg.Test("google") Then Debug.Print "google:match!"      'マッチする
    If Reg.Test("goooogle") Then Debug.Print "goooogle:match!"  'マッチする
    Debug.Print "---"
End Sub


<{m,n}⇒m回以上n回以下繰り返す場合にマッチ>
Sub SampleCode14()
    Dim Reg As Object
    Set Reg = CreateObject("VBScript.RegExp")
    
    Reg.Pattern = "go{1,2}gle" '正規表現セット oが1回以上2回以下続く時にマッチ
    If Reg.Test("ggle") Then Debug.Print "ggle:match!"          'マッチしない
    If Reg.Test("gogle") Then Debug.Print "gogle:match!"        'マッチする
    If Reg.Test("google") Then Debug.Print "google:match!"      'マッチする
    If Reg.Test("goooogle") Then Debug.Print "goooogle:match!"  'マッチしない
    Debug.Print "---"
End Sub


<?⇒1回以上繰り返す場合にマッチ>
Sub SampleCode15()
    Dim Reg As Object
    Set Reg = CreateObject("VBScript.RegExp")
    
    Reg.Pattern = "html?" '正規表現セット
    If Reg.Test("test.html") Then Debug.Print "test.html:match!"  'マッチする
    If Reg.Test("test.htm") Then Debug.Print "test.htm:match!"    'マッチする
    Debug.Print "---"
End Sub
htmとhtmlのように一部の文字があるかないかと言った時にメタ文字?を使います。
まだ、メモしていませんが、括弧表現を使うと
VB(Script)? でVBとVBScriptにマッチさせれます




■IgnoreCaseを使ってマッチするか判断する
<IgnoreCaseプロパティ⇒(デフォルト)False:大文字小文字区別する、True:大文字小文字区別しない>
たとえば、ある文章の中に書かれているvbscriptにマッチさせて数を数えようとした場合
どこが大文字でどこが小文字で書くかは、人それぞれになってしまいます。
そこで、大文字小文字を気にしない場合は、IgnoreCaseプロパティをTrueに設定します。
デフォルトは、False
Sub SampleCode16()
    Dim Reg As Object
    Set Reg = CreateObject("VBScript.RegExp")
    Reg.Pattern = "vbscript" '正規表現セット IgnoreCaseはセットしない=大文字小文字を区別する
    
    If Reg.Test("VBScript") Then Debug.Print "VBScript:match!"  'マッチしない
    If Reg.Test("vbscript") Then Debug.Print "vbscript:match!"  'マッチする
    If Reg.Test("vBsCrIpT") Then Debug.Print "vbscript:match!"  'マッチしない
    
    Reg.IgnoreCase = True '大文字小文字を区別しない
    If Reg.Test("VBScript") Then Debug.Print "VBScript:match!"  'マッチする
    If Reg.Test("vbscript") Then Debug.Print "vbscript:match!"  'マッチする
    If Reg.Test("vBsCrIpT") Then Debug.Print "vbscript:match!"  'マッチする
    Debug.Print "---"
End Sub



■マッチした内容を取り出す
<1つマッチした内容を取り出す>
Testメソッドではマッチするかしないかしか判別できない為
Executeメソッドを使って、マッチした時の詳細情報を取得する必要があります。
1つだけマッチした後に、使えるプロパティは以下の通りです
Sub SampleCode17()
    Dim Reg As Object, result As Object
    Set Reg = CreateObject("VBScript.RegExp")
    
    Reg.Pattern = "\d+" '正規表現セット
    Set result = Reg.Execute("消費税10%") '検査する文字列
    If 0 < result.Count Then
        Debug.Print "マッチした数  :" & result.Count               '1
        Debug.Print "何文字目にマッチ:" & result.Item(0).FirstIndex  '3(最初の文字にヒットすると0)
        Debug.Print "マッチの文字数 :" & result.Item(0).Length      '2
        Debug.Print "マッチした文字列:" & result.Item(0).Value       '10
    End If

    Debug.Print "---"
End Sub
マッチ結果オブジェクト.Count   ⇒ マッチした数 マッチ結果オブジェクト.Item(0).FirstIndex ⇒ 何文字目にマッチしたか。ただし最初の文字は0とする <複数マッチした内容を取り出すGlobalプロパティ>
Sub SampleCode18()
    Dim Reg As Object, result As Object
    Set Reg = CreateObject("VBScript.RegExp")
    
    Reg.Pattern = "\w{3}" '正規表現セット
    Reg.Global = True
    
    Set result = Reg.Execute("abcdefghijklmnop") '検査する文字列
    Dim i As Integer
    If 0 < result.Count Then
        Debug.Print "マッチした数  :" & result.Count
        Debug.Print ""
        For i = 0 To result.Count - 1
            Debug.Print "何文字目にマッチ:" & result.Item(i).FirstIndex
            Debug.Print "マッチの文字数 :" & result.Item(i).Length
            Debug.Print "マッチした文字列:" & result.Item(i).Value
            Debug.Print "---"
        Next
    End If

    Debug.Print "---------"
End Sub
実行結果--
マッチした数  :5
何文字目にマッチ:0
マッチの文字数 :3
マッチした文字列:abc
---
何文字目にマッチ:3
マッチの文字数 :3
マッチした文字列:def
---
何文字目にマッチ:6
マッチの文字数 :3
マッチした文字列:ghi
---
何文字目にマッチ:9
マッチの文字数 :3
マッチした文字列:jkl
---
何文字目にマッチ:12
マッチの文字数 :3
マッチした文字列:mno
---
---------
<()を使ってマッチした内容の一部を取り出す>
()には、二つの役割があります
一つは正規表現をグループとして扱う場合
VB(Script)?
とした場合
Script
という塊がある時とない時にマッチします。
もう一つの役割が括弧内の内容を記憶してSubMatchesプロパティで取り出すことができます。
以下のコードでは、郵便番号の3桁部と4桁部と3桁-4桁部を括弧でくくっています。
注意するべき点は、括弧をネストした場合どこから表示されるかということでしょうか?
では、サンプルコードです。
Sub SampleCode19()
    Dim Reg As Object, result As Object
    Set Reg = CreateObject("VBScript.RegExp")
    
    Reg.Pattern = "〒((\d{3})-(\d{4}))" '正規表現セット
    
    Set result = Reg.Execute("〒123-4567") '検査する文字列
    Dim x As Integer, y As Integer
    If 0 < result.Count Then
        Debug.Print "マッチした数  :" & result.Count
        Debug.Print ""
        For x = 0 To result.Count - 1
            Debug.Print "何文字目にマッチ:" & result.Item(x).FirstIndex
            Debug.Print "マッチの文字数 :" & result.Item(x).Length
            Debug.Print "マッチした文字列:" & result.Item(x).Value
            Debug.Print "()でヒットした数:" & result.Item(x).Submatches.Count
            
            If 0 < result.Item(x).Submatches.Count Then '()内でマッチした内容を表示
                For y = 0 To result.Item(x).Submatches.Count - 1
                    Debug.Print result.Item(x).Submatches.Item(y)
                Next
            End If
        Next
    End If

    Debug.Print "---"
End Sub
実行結果---
マッチした数  :1

何文字目にマッチ:0
マッチの文字数 :9
マッチした文字列:〒123-4567
()でヒットした数:3
123-4567
123
4567
---

括弧がネストしている場合は、左側の括弧"("が登場した順番に表示されます
1.全体をくくる括弧 ((\d{3})-(\d{4}))
2.\d{3}をくくる括弧 ((\d{3})-(\d{4}))
3.全体をくくる括弧 ((\d{3})-(\d{4}))

ちなみに、始まり括弧"("の後に"?:"をつけるとメモリに記憶されません。
どういうことかと言うと、括弧にはグループとしての役割と括弧内の文字列をメモリに記憶するという二つの役割があるわけですが、前者の役割のうち定形文字列をグループとした場合マッチした内容は改めて取り出す必要もないのでそういう場合に使います。

例:java(script)?
java と javascriptにマッチさせたい場合
この時、括弧の中身は定形の文なので改めて取り出す必要はないので
java(?:script)?
と、記載された場合メモリに記憶されません。

括弧でグルーピングしていった時にメモリの内容を取り出す際にFor文等のループで取り出すことになると思うのですが複数箇所括弧でくくったうち、その中に定型文があった時は除外したいですよねぇ。利用方法はそんな感じですね。

■位置条件を使ってマッチするか判断する。
メタ文字意味
^文字列の先頭にマッチ
$文字列の末尾にマッチ
\b単語区切りの後にマッチ
\B単語区切り以外の部分にマッチ
これについては、まとめてコードで確認していきましょう。
Sub SampleCode20()
    Dim Reg As Object, Result As Object
    Set Reg = CreateObject("VBScript.RegExp")
    Reg.Global = True
    
    Dim TestStr As String
    TestStr = "abcdefg hijklmn" & vbCrLf & "opqrstu" & vbCrLf & "vwxyzAB"
    
    Reg.Pattern = "^[a-zA-Z]{3}" '正規表現セット
    Set Result = Reg.Execute(TestStr) '検査する文字列
    Call DebugPrint(Reg, Result)
    Debug.Print "---------"
    
    Reg.Pattern = "[a-zA-Z]{3}$" '正規表現セット
    Set Result = Reg.Execute(TestStr) '検査する文字列
    Call DebugPrint(Reg, Result)
    Debug.Print "---------"
    
    Reg.Pattern = "\b[a-zA-Z]{3}" '正規表現セット
    Set Result = Reg.Execute(TestStr) '検査する文字列
    Call DebugPrint(Reg, Result)
    Debug.Print "---------"
    
    Reg.Pattern = "\B[a-zA-Z]{3}" '正規表現セット
    Set Result = Reg.Execute(TestStr) '検査する文字列
    Call DebugPrint(Reg, Result)
    Debug.Print "---------"
    
End Sub

Sub DebugPrint(Reg As Object, Result As Object)
    Debug.Print "正規表現:" & Reg.Pattern
    Dim x As Integer
    If 0 < Result.Count Then
        For x = 0 To Result.Count - 1
            Debug.Print "マッチした文字列:" & Result.Item(x).Value
        Next
    End If
End Sub
実行結果---
正規表現:^[a-zA-Z]{3}
マッチした文字列:abc
---------
正規表現:[a-zA-Z]{3}$
マッチした文字列:zAB
---------
正規表現:\b[a-zA-Z]{3}
マッチした文字列:abc
マッチした文字列:hij
マッチした文字列:opq
マッチした文字列:vwx
---------
正規表現:\B[a-zA-Z]{3}
マッチした文字列:bcd
マッチした文字列:efg
マッチした文字列:ijk
マッチした文字列:lmn
マッチした文字列:pqr
マッチした文字列:stu
マッチした文字列:wxy
マッチした文字列:zAB
---------

正規表現:^[a-z]{3}
"abcdefg hijklmn" & vbCrLf & "opqrstu" & vbCrLf & "vwxyzAB"

正規表現:[a-z]{3}$
"abcdefg hijklmn" & vbCrLf & "opqrstu" & vbCrLf & "vwxyzAB"

正規表現:\b[a-zA-Z]{3}
"abcdefg hijklmn" & vbCrLf & "opqrstu" & vbCrLf & "vwxyzAB"

正規表現:\B[a-zA-Z]{3}
"abcdefg
hijklmn" & vbCrLf & "opqrstu" & vbCrLf & "vwxyzAB"

尚、区切り文字となるのは\Wに該当するものです。 つまりアルファベット、数字、アンダーバー(_)以外です

■ | で複数の条件を使ってマッチするか判断する。
|の前後のどちらかを含むとマッチとなります。
Sub SampleCode21()
    Dim Reg As Object, result As Object
    Set Reg = CreateObject("VBScript.RegExp")
    
    Reg.Pattern = "abc|def" '正規表現セット
    Set result = Reg.Execute("abc")
    If result.Count Then Debug.Print result.Item(0).Value
    Set result = Reg.Execute("def")
    If result.Count Then Debug.Print result.Item(0).Value

    Reg.Pattern = "ab(c|d)ef" '正規表現セット
    Set result = Reg.Execute("abcef")
    If result.Count Then Debug.Print result.Item(0).Value
    Set result = Reg.Execute("abdef")
    If result.Count Then Debug.Print result.Item(0).Value

    
    Debug.Print "---"
End Sub
実行結果---
abc
def
abcef
abdef
---

■後方参照を使ってマッチするか判断してみる
問題。
wii、seeといったように3文字で2文字目と3文字目が同じ文字だけど
1文字目とは違うといった文字列はどのようにマッチさせればよいでしょう?
残念ながら、今までやってきた方法では表現できません。。

結論から言うと「\(数字)」を使います。
()でを使ってマッチさせた場合メモリにその内容が記録されます。
それと同時にマッチした順番に\1、\2、\3…といった順番に
()内の内容が正規表現内で利用できるようになります。

seeやwiiにマッチさせたい時は、下記のように書きます。
[a-zA-Z]([a-zA-Z])\1
Sub SampleCode22()
    Dim Reg As Object, result As Object
    Set Reg = CreateObject("VBScript.RegExp")
    Reg.Pattern = "[a-zA-Z]([a-zA-Z])\1"
    
    Set result = Reg.Execute("Wii")
    If result.Count Then Debug.Print result.Item(0).Value 'Wii

    Set result = Reg.Execute("see")
    If result.Count Then Debug.Print result.Item(0).Value 'see
End Sub
■マッチした内容を置換する
Sub SampleCode22()
    Dim Reg As Object, result As Object, str As String
    Set Reg = CreateObject("VBScript.RegExp")
    Reg.Pattern = "\d"
    Reg.Global = True
    
    str = Reg.Replace("ab2489c19d210e2190f1g082hi102jk1l1mn", "") '数字を全て空文字に置換
    Debug.Print str 'abcdefghijklmn
End Sub
■マッチした内容を置換する2
さて問題です。文字列中にあるjavascriptをscriptjavaにするにはどうしたらよいでしょうか?
Sub SampleCode23()
    Dim Reg As Object, result As Object, str As String
    Set Reg = CreateObject("VBScript.RegExp")
    Reg.Pattern = "(java)(script)"
    Reg.IgnoreCase = True
    
    str = Reg.Replace("好きな言語JavaScriptです", "$2$1") '前後入れ替える
    Debug.Print str '好きな言語ScriptJavaです
End Sub
■最後に、時計の正規表現を改めて考えてみる
0:00から23:59分を表現する正規表現を考える。
分に関しては、常に10の桁が0-6、1の桁が0-9の固定。
:[0-5][0-9]となる。
時間の方は、場合分けが発生する
10の桁がない時、1の桁0-9
10の桁が1の時、1の桁0-9
10の桁が2の時、0-3

以上を合わせるとこうなる。
 ([0-9]|1[0-9]|2[0-3]):[0-5][0-9]

最初の、[0-9]|1[0-9]の部分は1がある時とない時なので1?[0-9]にまとめれます
(1?[0-9]|2[0-3]):[0-5][0-9]

[0-9]は\dで表現できるので
(1?\d|2[0-3]):[0-5]\dで表現されます。

2012年12月24日月曜日

[ExcelVBA] 二次元配列を簡単に操作するClass


アドベントカレンダー 24日目

データを蓄積してそれを最後にセルに出力するなんてことはあると思うのですが
データ量が増えるとエクセルに出力する部分がえらく時間がかかるようになります
高速で出力するには、配列に格納して出力するのが最速となります。
ただ…
出力する時に行と列をいれかえる必要があったりCollectionならAddするだけで
要素が追加できるとこをいちいち、要素数が存在しない時と存在する時で処理を
分岐して毎回Redim Preserveしなきゃいけないなんてのはめんどくさい以外の
何者でもありません。

そういうのは、裏側でこっそり処理して表側には見えないようにしてあげた方が便利よいですよね。
そんなわけで、セルに出力することに特化させた二次元配列のクラスを作ってみました。
Option Explicit

Dim Data()    As String
Dim x         As Long
Dim y         As Long
Dim DelColumn As Integer

'Setter/Getter
Public Property Let DeleteColumn(ByVal num As Integer)
    DelColumn = num
End Property

Public Property Get DeleteColumn() As Integer
    DeleteColumn = DelColumn
End Property

Private Sub Class_Initialize()

    '初期化
    x = -1
    y = -1

End Sub

Function Count()

    '要素数を返す
    Count = UBound(Data, 2) + 1

End Function

Function Item(ByVal a As Long, ByVal b As Long)
    
    '要素の値を返す
    Item = Data(a, b)
    
End Function

Function Last()

    '最終要素を返す
    Last = UBound(Data, 2)

End Function

Private Function TransposeData()
    Dim s        As Long
    Dim t        As Long
    Dim TPData() As String
    ReDim TPData(y, x)
    
    For s = 0 To y
        For t = 0 To x
            TPData(s, t) = Data(t, s)
        Next
    Next
    
    TransposeData = TPData
End Function

Function Value() As String()

    '2次元配列自体を返す
    Value = Data()

End Function

Sub Add(ByRef list As Variant)
    Dim i As Long
    
    '1次元の要素数が確定していない時、要素数の調査をおこなう
    If x = -1 Then
        
        If TypeName(list) = "Variant()" Then
            
            x = UBound(list)
        
        Else
            
            x = 0
        
        End If
    
    End If
    
    
    '要素数の再定義
    y = y + 1
    ReDim Preserve Data(x, y)
    
    If TypeName(list) = "Variant()" Then
        
        For i = 0 To x
        
            '要素数が足りないときは、空文字を指定
            On Error Resume Next
            Data(i, y) = list(i)
            On Error GoTo 0
        
        Next
        
    Else
    
        Data(x, y) = list
    
    End If

End Sub

Sub Clear()
    Erase Data
    DelColumn = -1
    x = -1
    y = -1
End Sub

Sub Output(ByVal Sht As Worksheet, ByVal Cell As String)
    Dim BaseRow As Long
    Dim BaseCol As Long
    
    BaseRow = Sht.Range(Cell).Row
    BaseCol = Sht.Range(Cell).Column
    
    'DelColumnが1以上でセットされている時該当列をクリアする
    If 0 < DelColumn Then
        Sht.Range(Sht.Cells(BaseRow, BaseCol), Sht.Cells(65536, BaseCol + DelColumn)).Clear
    End If
    
    Sht.Range(Sht.Cells(BaseRow, BaseCol), Sht.Cells(BaseRow + y, BaseCol + x)) = TransposeData()
    
End Sub
好きな名前でもつけてくださいな。 使い方ですがサンプル内にコメントで追加しました。 ■値の追加、値の取り出し
Option Explicit

Sub SampleCode1()
    Dim Data As New Hogehoge
    Dim i As Long
    
    
    'Addメソッドに対し、Array関数で配列を作って渡せばよいです
    Call Data.Add(Array("A01", "B05", "C001", "D1", "なんとなくだめ"))
    Call Data.Add(Array("A01", "B10", "C002", "D2", "それとなくだめ"))
    Call Data.Add(Array("A01", "B15", "C003", "D3", "そこはかとなくだめ"))
    Call Data.Add(Array("A01", "B20", "C004", "D4", String(256, "■")))


    '一つ一つのデータにアクセスしたい場合はItemメソッドで
    '通常の二次元配列のようにアクセスするとよいです。
    For i = 0 To Data.Last
        Debug.Print Data.Item(0, i) & Data.Item(1, i) & Data.Item(2, i)
    Next
    
    
    '出力する際、いちいち領域を指定する必要はありません。
    '出力したいシートのオブジェクトと左上のセルを指定するだけで十分です。
    Call Data.Output(ThisWorkbook.ActiveSheet, "B3")
    
    '連続してコードを実行して出力する場合、前回出力したデータが残ってしまうので
    '出力時に該当する行より後ろの行をClearしたい時は、事前に列数を指定すると削除してくれます。
    Data.DeleteColumn = 5
    Call Data.Output(ThisWorkbook.ActiveSheet, "B3")
    
    'Clearメソッドで初期化されます。
    Call Data.Clear
    
    '一元配列ならいちいちArray関数にいれる必要はありません。
    Call Data.Add("abc")
    Call Data.Add("def")
    Call Data.Add("ghi")
    
    Call Data.Output(ThisWorkbook.ActiveSheet, "A10")
End Sub

2012年12月23日日曜日

[ExcelVBA] 配列の値をループを使わずに計算する


アドベントカレンダー 23日目

CSVなんかでデータを取得して合計値でも求めたいなぁ
なんてことはまれにあるとおもいますが、
ループでぐるぐる回して合計値を出すのはちょっと面白みにかけるので
こんな方法はどうですか?
という小ネタです。
(ネタですよ・・・)
Option Explicit

Sub SampleCode()
    Dim Data As Variant

    'データは何かしらの方法で受け取るとして…ここではArrayで作っちゃいます
    Data = Array(30, 29, 58, 38, 10, 38, 26, 65, 93)

    '足し算をする
    Debug.Print Evaluate(Join(Data, "+"))
End Sub

足し算記号で配列をJoinして
" 30+29+58+38+10+38+26+65+93"
という文字列を作り上げ、Evaluateで文字列を評価してあげるだけです。

単にEvaluateを使いたかっただけなんですけどねぇ…

ちなみに、Evaluate関数は
Evaluate("A1")でアクティブのA1の値を取得します。
特に使い道はないですね。

2012年12月22日土曜日

[ExcelVBA] ワークシート関数を増やす


アドベントカレンダー 22日目

マクロばかりに目がいくとどうも忘れがちになるというか
こういう使い方をしたい時がないからなのか登場場面が少ないきがしますが
マクロに書いたPublicなFunctionはワークシート関数から使えますよね。

例) BMIを求める関数を実装する
BMIの式は
BMI = 体重 ÷ 身長 ÷ 身長 ですね
Option Explicit

Function BMI(ByVal Height As Double, ByVal Weight As Double) As Double

    BMI = Weight / Height ^ 2

End Function

これでワークシート内で=BMI(1.7, 60)の
ように記載すると値が返ってきます。

何かしらの公式など、関数化してワークシート内で使いまわすなんてやり方は便利よいですね。
自分の場合、力学系の式を登録して、簡易的なチェックとして使っていたりしましたね。

もちろん、関数の挿入[fx]で確認してみても他の関数と同様に示されます。


ただ・・・
説明がないといまいちそっけないですね。

とういうわけで、ヘルプを追加してみます。
Option Explicit

Function BMI(ByVal Height As Double, ByVal Weight As Double) As Double

    BMI = Weight / Height ^ 2

End Function


Sub OwnFunctionHelp()

    Application.MacroOptions Macro:="BMI", _
    Description:="引数は以下の通りです。" & vbLf & "Height:身長[m], Weight:体重[kg]"

End Sub
OwnFunctionHelpを実行すると説明が表示されるようになります。



あくまでもマクロを実行することで追加されるのでExcelが開いたら実行されるようにしておく必要があります。
標準モジュールならAuto_Open関数を作りそこから呼び出すようにするか
ThisWorkbookならWorkbook_Open関数から呼び出すようにする必要があります。

2012年12月21日金曜日

[ExcelVBA] 再帰処理 - QuickSort


アドベントカレンダー 21日目

前日に引き続き、再帰処理の例をあげてみます。
今度はQuickSortです。
この例では、配列のデータは整数のみ限定ということで書いています。

Option Explicit

Sub QuickSort(ByRef Data As Variant, Optional ByVal S As Integer = 0, Optional ByVal E As Integer = -1)
    Dim BaseValue  As Long
    Dim ChangeData As Long
    Dim TempEnd    As Long
    Dim TempStart  As Long
    
    If E = -1 Then E = UBound(Data)
    
    '基準の値を決定(ひとまず中間の要素値を基準とする)
    BaseValue = CLng(Data(Int((S + E) / 2)))

    TempStart = S
    TempEnd = E
    Do
        '基準値より大きい値の要素を探す
        '該当するものがなければ基準値の要素でStopする
        Do While CLng(Data(TempStart)) < BaseValue
            TempStart = TempStart + 1
        Loop
        
        '基準値より小さい値の要素を探す
        '該当するものがなければ基準値の要素でStopする
        Do While BaseValue < CLng(Data(TempEnd))
            TempEnd = TempEnd - 1
        Loop
    
        'Start側の要素数がEnd側の要素数と一致した場合
        '入れ替える物がなかったためこのループは終了とする
        If TempEnd <= TempStart Then Exit Do
    
        'データを入れ替える
        ChangeData = Data(TempStart)
        Data(TempStart) = Data(TempEnd)
        Data(TempEnd) = ChangeData
        
        '範囲をそれぞれ一つずつ狭める
        TempStart = TempStart + 1
        TempEnd = TempEnd - 1
    Loop
    
    '状況によってさらにソートを続ける
    If S < TempStart - 1 Then Call QuickSort(Data, S, TempStart - 1)
    If TempEnd + 1 < E Then Call QuickSort(Data, TempEnd + 1, E)
End Sub


Sub SampleCode()
    Dim Data As Variant
    
    Data = Array(34, 96, 43, 78, 35, 69, 6, 3, 50, 34, 55, 44)
    
    Call QuickSort(Data)
    Debug.Print Join(Data, ",")
End Sub
ただし、QuickSortは安定ソートでないため 一次元配列に対してしか使うことができず 二次元配列には別のソートアルゴリズムを使う必要があります。

2012年12月20日木曜日

[ExcelVBA] 再帰処理 - サブフォルダ内のファイル


アドベントカレンダー 20日目

再帰処理といえば、ある一定の処理が繰り返し
樹木の枝のように発生する場合に使う処理ですね。

例えば、サブフォルダ内のファイルを検索する場合



該当するファイルを探すという行為をフォルダを見つけるたびに1階層下に移動し繰り返しているだけですよね。
こういったパターンの時に使えますね。
他の例だと、クイックソートとかも使いどころですよね。

まずは、再帰処理を使う必要がないくらい単純な例を使って実際に使ってみましょう。
では、10カウントダウンする関数を考えてみます。

普通に書くと、以下のように書けば実現できます。
Option Explicit

Sub SampleCode()
    Call CountDown(10)
End Sub

Sub CountDown(ByVal num As Integer)
    Dim i As Integer
    
    For i = num To 1 Step -1
        Debug.Print i
    Next
End Sub

これと同様のことを再帰処理で実現すると…
Option Explicit

Sub SampleCode()
    Call CountDown(10)
End Sub

Sub CountDown(ByVal num As Integer)
    Debug.Print num
    If 1 < num Then Call CountDown(num - 1)
End Sub
シンプルですねぇ。 これは、カウントするという行為を10回繰り返していて 値だけが変わっているということに着目して書き換えたものです。 ただ、fot文で簡単にかけちゃうといまいち再帰処理のメリットを感じませんね そんなわけで、実際にサブフォルダ内のファイルを探すプログラムあたりを 書いてみると再帰処理のよさを感じられると思うので実際に書いてみるとよいと思います。 参考までに、自分が作成した関数を掲載しておきます。
Option Explicit

Function GetSubFolder(ByRef FilePaths As Object, ByVal CurrentFolder As String, Optional ByVal NameRule As String = "*")
    Dim FileName As String
    Dim Folder   As Variant
    Dim Folders  As Object
    Dim FSO      As Object
    Dim TopFlag  As Boolean
    
    '** Objectの生成 **
    Set FSO = CreateObject("Scripting.FileSystemObject")
    
    '存在しないパスのときは、関数を抜ける
    If Not FSO.FolderExists(CurrentFolder) Then Exit Function
    
    '該当するファイルの取得
    FileName = Dir(CurrentFolder & "\" & NameRule)
    
    Do While FileName <> ""
        
        FilePaths.Add CurrentFolder & "\" & FileName, FileName
        FileName = Dir()
    
    Loop

    'サブフォルダの処理
    Set Folders = FSO.GetFolder(CurrentFolder)
    
    'サブフォルダを一つずつループで処理する
    For Each Folder In Folders.SubFolders
        
        'さらにその下の階層を調べる
        Call GetSubFolder(FilePaths, Folder.Path, NameRule)
    
    Next

    Set FSO = Nothing
    Set Folders = Nothing
End Function

'実際に使ってみる
Sub SampleCode()
    Dim CurrentFolder As String
    Dim FilePath      As Variant
    Dim FilePaths     As Object
    
    '** Objectを生成 **
    Set FilePaths = CreateObject("Scripting.Dictionary")
    
    '引数
    '第一引数:見つかったパスを格納するDictionary
    '          Dictionaryはキーにフルパス、値にファイル名
    '第二引数:検索開始のフォルダパス
    '第三引数:Dir関数同様に探しだすファイル名をアスタリスクを使って指定。
    
    'ファイルを探し出すフォルダパス
    CurrentFolder = "C:\Documents and Settings\Owner\My Documents\excel\test"
    
    '検索開始
    Call GetSubFolder(FilePaths, CurrentFolder, "*")

    '検索結果を出力
    For Each FilePath In FilePaths
        Debug.Print "フルパス:" & FilePath
'        Debug.Print "ファイル:" & FilePaths.Item(FilePath)
    Next
    
    Set FilePaths = Nothing
End Sub

2012年12月19日水曜日

[ExcelVBA] テキストボックスの連動


アドベントカレンダー 19日目

あるシートにテキストボックスを用意しファイルパスなど設定事項を
入力するよう指定していたら別のシートからも変更できるように
お願いできますか?と、言われたとします。

確かに…
設定だけ、あるシートにまとめておくと管理はしやすいものの
いちいち、そこに移動して入力し、また戻ってくるってのは
いささかめんどくさく感じる時もありますよね。

そういった場合、テキストボックス同士どちらで変更しても
同じ情報となるように細工したくなりますよね。
さてどうします?

具体例として以下のケースに出くわしたとします。
(あくまでも例です)

シートは3つあります。
Aシートにはテキストボックスが3つ。
Bシートにはテキストボックスが2つ。
Cシートにはテキストボックスが1つ。

テキストボックス3については、3つのシートどこからでも操作がしたく
それぞれ同期がとれていてほしいわけです。
テキストボックス2は、2つのシートから操作がしたく
それぞれ同期がとれていてほしいわけです。


何も考えずにストレートにコードを書くとこうなりますね。
'Sheet Aのモジュール
Private Sub TextBox2_Change()
    ThisWorkbook.Sheets("B").TextBox2.Text = Me.TextBox2.Text
End Sub

Private Sub TextBox3_Change()
    ThisWorkbook.Sheets("B").TextBox3.Text = Me.TextBox3.Text
    ThisWorkbook.Sheets("C").TextBox3.Text = Me.TextBox3.Text
End Sub


'Sheet Bのモジュール
Private Sub TextBox2_Change()
    ThisWorkbook.Sheets("A").TextBox2.Text = Me.TextBox2.Text
End Sub

Private Sub TextBox3_Change()
    ThisWorkbook.Sheets("A").TextBox3.Text = Me.TextBox3.Text
    ThisWorkbook.Sheets("C").TextBox3.Text = Me.TextBox3.Text
End Sub


'Sheet Cのモジュール
Private Sub TextBox3_Change()
    ThisWorkbook.Sheets("A").TextBox3.Text = Me.TextBox3.Text
    ThisWorkbook.Sheets("B").TextBox3.Text = Me.TextBox3.Text
End Sub

素直にベタ書きしたところです。
今後拡張された場合、どのテキストボックスがどうなってるか
関係を確認した上でコードを追加する必要が生じます。

そんな面倒臭い書き方はしたくないのでもっと楽するには以下のように書きます。
'Sheet Aのモジュール
Private Sub TextBox2_Change()
    Call AllSheetTextBoxChange("TextBox2", TextBox2.Value)
End Sub

Private Sub TextBox3_Change()
    Call AllSheetTextBoxChange("TextBox3", TextBox3.Value)
End Sub


'Sheet Bのモジュール
Private Sub TextBox2_Change()
    Call AllSheetTextBoxChange("TextBox2", TextBox2.Value)
End Sub

Private Sub TextBox3_Change()
    Call AllSheetTextBoxChange("TextBox3", TextBox3.Value)
End Sub


'Sheet Cのモジュール
Private Sub TextBox3_Change()
    Call AllSheetTextBoxChange("TextBox3", TextBox3.Value)
End Sub

'↑ある関数に対し所定の書き方を繰り返すのみですね。

'標準モジュール
Sub AllSheetTextBoxChange(ByVal ControlName As String, ByVal Text As String)
    On Error Resume Next '存在しないテキストボックス名の可能性を考慮
    
    ThisWorkbook.Sheets("A").OLEObjects(ControlName).Object.Value = Text
    ThisWorkbook.Sheets("B").OLEObjects(ControlName).Object.Value = Text
    ThisWorkbook.Sheets("C").OLEObjects(ControlName).Object.Value = Text
    
    On Error GoTo 0
End Sub
今後拡張したい時は、AllSheetTextBoxChangeにシート名を追加するのみです。
以上

2012年12月18日火曜日

[ExcelVBA] Debug.Printで200回以上使っても見切れない方法


アドベントカレンダー 18日目

さて、そろそろネタも少なくなってきたので
だれが使っているんだろう・・・
みたいなネタを一つ。

Debug.Printでイミディエイトウィンドウに出力した際
200行を超えると先頭の行から消えて行くため、
それ以上を一度に表示することはできません。

厳密には、199回+改行で200行となるので199回出力したらその次から最初の方から削除されることになります。

Option Explicit

Sub SampleCode()
    Dim i As Integer
    
    For i = 1 To 199
        Debug.Print i
    Next
End Sub
↑これが限界?

ちょっと悔しいですね。
じゃ、それ以上表示しましょ。

Option Explicit

Sub SampleCode()
    Dim i As Integer
    
    For i = 1 To 300
        Debug.Print i;
    Next
End Sub

これで楽勝ではいりましたね。
Debug.Printの最後尾に ; をつけると改行されません!
以上。

2012年12月17日月曜日

[ExcelVBA] ショートカット


アドベントカレンダー 17日目

ショートカットといえば、いろんな物が用意されており
その人その人の操作の仕方に応じて便利よいものを使えばいいと思います。

そんな中でも、やっぱりこれ便利だよね。
ってのをいくつかめもめも。

■セルのところで
・Ctrl + ; → 日付を表示
・Ctrl + : → 時間を表示
これは、かなり有名ですよね。
よくつかいます。


■VBEのところで
・       F8 → ステップ イン
・   Shift + F8 → ステップ オーバー
・Ctrl + Shift + F8 → ステップアウト
マクロのステップ実行に関するショートカットです。
これも覚えておくと便利ですよね。


■VBEのところで
・Ctrl + スペース → 入力候補を表示。ただし、候補が一つの時は候補を表示することなく残りの単語を補う

入力補助が表示されている時にミスタッチしてdeleteしたりして
打ち直しした時に、入力補助が表示されなくなることがあるので
そういった時は、Ctrl + スペースで補ってあげるとよいですね。


2012年12月16日日曜日

[ExcelVBA] コントロールをRGBで指定


アドベントカレンダー 16日目

ユーザーコントロールの背景色ってぱっとしないですよねぇ。
極めて、Excel的で、面白みがない。。。


でも、RGBで指定も可能なんでRGBで指定しちゃいましょ。



試しに白を指定してみると、上のような結果が得られます。
白はRGB255,255,255を16進数に変換するとFF,FF,FFとなるので
どうやら&H00 と & の間にRGBの値を記載すればよいということのようです。
ただし、左側からBGRの順番で指定する必要があります。

実際にやってみましょう。
下のような色を指定したい時で考えます。


255 と 128ですね。
16進数に変換しましょう。
電卓の関数電卓モードで計算するもよいし、
イミディエイトウィンドウで計算するのでもよいですよね。
お好きな方法で計算しちゃってくださいな。



FF と 80ですね。
では指定してみます。

B→G→Rの順番で指定するので80→80→FFですね



これでお好きな色が指定できますね。


2012年12月15日土曜日

[ExcelVBA] すけすけあぷりけーしょん


アドベントカレンダー 15日目

いやー
ディスプレイが小さいと表示できる面積が小さいから
どうしてもあれもこれも見たいって時に困りますよねぇ。

じゃ、透過すればいいじゃない!
ということで、今日のネタは前日のWindowsAPIの
ハンドル取得を利用して任意のアプリを透明化するあぷりです。

簡単なデモでも紹介します。
まず、電卓を2つ立ち上げスケルトンアプリを立ち上げます。
そして、検索欄に"電卓"と入力してEnterを押します。
この検索欄は、ウィンドウ名を指定します。
簡単な正規表現込みで指定可能です。

するとヒットしたものがリストとして表示されます。


透明にしたい方を選択して、透明にしたい割合(右上のボックス)を0〜100で指定します。
0が透明で100が不透明です。


<30%にした場合>

Excel自体を半透明にすることも…



スケルトンアプリで遊びたい時はこちらからどーぞ
https://docs.google.com/open?id=0B_9e7wIj6Kvua0dtMVhoWHJfN0E

2012年12月14日金曜日

[ExcelVBA] ウィンドウハンドルを取得する - WindowsAPI


アドベントカレンダー 14日目

クラス名がわかっていれば、FindWindow関数でも使ってハンドル取得すりゃいい話なんですが
わからん時は、いちいちEnumWindows関数で全ハンドル取得してウィンドウ名を取得して
該当するハンドルを見つけりゃいいわけですが、ちょいとめんどくさいから関数作ってしまいましょ。

関数の仕様としては、欲しいウィンドウハンドルの名前を指定します。
指定の仕方は正規表現で指定できます。
返り値は、DictionaryのObjectが返ってきます。

Dictionaryの構造は、ハンドルをキーに値にDicitionaryを持ちます。
そのDicitionaryは
ClassName という文字列をキーにクラス名を値に
WIndowName という文字列をキーにウィンドウ名を値に持ちます。

(Dictionary) = Hwnd => (Dictionary)
                                       "ClassName"     => [クラス名],
                                       "WIndowName" => [ウィンドウ名]
 

コードは以下の通りです。
Option Explicit

Private Declare Function EnumWindows Lib "user32.dll" (ByVal lpEnumFunc As Long, lParam As Long) As Long
Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" _
       (ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Private Declare Function SendMessageStr Lib "user32.dll" Alias "SendMessageA" _
       (ByVal hwnd As Long, ByVal MSG As Long, _
        ByVal wParam As Long, ByVal lParam As String) As Long

Private Const WM_GETTEXT = &HD
Private Const WM_GETTEXTLENGTH = &HE

Private DicHwnd As Object
Private RegWindowTitle As Object

Public Function GetHwnd(ByVal RegPattern As String) As Object
    Dim Ret As Long
    
    'FileNameに一致するハンドルをキーにタイトルを値に格納する変数
    'CallBack関数とやりとりするのでGlobal領域で宣言しておく
    Set DicHwnd = CreateObject("Scripting.Dictionary")
    Set RegWindowTitle = CreateObject("VBScript.RegExp")
    
    RegWindowTitle.Global = False
    RegWindowTitle.IgnoreCase = True
    RegWindowTitle.Pattern = EscapeRegString(RegPattern)

    '必ずエラーになるので止まらないよう処理しておく
    On Error Resume Next
    Ret = EnumWindows(AddressOf EnumWindowsProc, 0)
    On Error GoTo 0 '問題の部分を過ぎたのでエラー処理をもとに戻す
    
    Set GetHwnd = DicHwnd
    Set DicHwnd = Nothing
End Function

Private Function EnumWindowsProc(ByVal hwnd As Long) As Long
    Dim ClassName   As String
    Dim length      As Integer
    Dim Ret         As Integer
    Dim str         As String
    Dim WindowTitle As String
    
    EnumWindowsProc = 1
    
    'ハンドルに該当する文字列数を取得(注:Null文字は含まない)
    length = SendMessageStr(hwnd, WM_GETTEXTLENGTH, 0, 0)
    length = length + 1 'Null文字分1つ増やす
    
    'Null文字分一つ多く領域を確保
    str = String(length, vbNullChar)
    
    'Null文字も含め受取る
    Ret = SendMessageStr(hwnd, WM_GETTEXT, length, str)
    
    '文字列を出力(NULL文字分1つ削って出力)
    WindowTitle = Left(str, Len(str) - 1)
    
    '取得したウィンドウ名がGetHwndの引数に指定された正規表現がマッチしたら取得しておく
    If RegWindowTitle.Test(WindowTitle) Then
        'クラス名が何文字か不明なので大きめの領域を確保しておく
        ClassName = String(255, vbNullChar)
        Ret = GetClassName(hwnd, ClassName, 255)
        ClassName = Replace(ClassName, vbNullChar, "")
        
        DicHwnd.Add CStr(hwnd), CreateObject("Scripting.Dictionary")
        DicHwnd(CStr(hwnd)).Add "ClassName", ClassName
        DicHwnd(CStr(hwnd)).Add "WindowName", WindowTitle
    End If
    
End Function

Private Function EscapeRegString(ByVal RegHwnd As String)
    RegHwnd = Replace(RegHwnd, "(", "\(")
    RegHwnd = Replace(RegHwnd, ")", "\)")
    RegHwnd = Replace(RegHwnd, ".", "\.")
    RegHwnd = Replace(RegHwnd, "[", "\[")
    
    EscapeRegString = RegHwnd
End Function


こんな感じで値が取れます。
メモ帳を2つ起動した状態で、メモ帳のハンドルを取得したいとします。
Option Explicit

Sub SampleCode()
    Dim hwnd     As Variant
    Dim HashHwnd As Object
    Set HashHwnd = GetHwnd("メモ帳$")
    
    For Each hwnd In HashHwnd
        Debug.Print "ハンドル:" & hwnd
        Debug.Print "クラス名:" & HashHwnd(hwnd)("ClassName")
        Debug.Print "タイトル:" & HashHwnd(hwnd)("WindowName")
        Debug.Print "---"
    Next
End Sub

実行結果

ハンドル:197350
クラス名:Notepad
タイトル:無題 - メモ帳
---
ハンドル:262876
クラス名:Notepad
タイトル:無題 - メモ帳
---


2012年12月13日木曜日

[ExcelVBA] ようこそ画面の名前


アドベントカレンダー 13日目

掲示板のような書き込み式のプログラムを作った際に
名前を自動で指定したいなんてことありますよねぇ。

会社なんかだと、ログインユーザー名がアルファベットで[苗字の頭文字]_[名前]
そして、ようこそ◯◯ って画面で漢字の名前が指定されていたりしますよね。
VBAからだと手っ取り早く取得できるのが、ログインユーザー名の方で下記で取得できます。

CreateObject("WScript.Network").UserName

ログとして取得するならまだしも、利用者同士が目にするとこで利用するなら
ようこそ◯◯画面で表示されるFullNameの方を取得したいものです。
FullNameのデータを取得する方法はいくつかあるのですが
セキュリティの関係で取得できないものがあったりするので
自分の環境で取得できたコードをのっけておきます。
他の方法、ネットで検索したらボロボロでてくるのでそちらにおまかせしておきます。

ここで紹介するのは、WMIを使った方法です。
Option Explicit

Sub main()
    Dim FullName As String
    Dim Locator  As Object
    Dim Service  As Object
    Dim QfeSet   As Object
    Dim Qfe      As Variant
    Dim UserName As String
    
    '** Objectの生成 **
    Set Locator = CreateObject("WbemScripting.SWbemLocator")
    Set Service = Locator.ConnectServer
    Set QfeSet = Service.ExecQuery("Select * From Win32_NetworkLoginProfile")

    UserName = CreateObject("WScript.Network").UserName

    For Each Qfe In QfeSet
        '名前にログイン名が使われているオブジェクトのFullNameを取得をしたい
        If 0 < InStr(Qfe.Name, UserName) Then
            
            FullName = Qfe.FullName
        
        End If
    
    Next

    MsgBox FullName

    Set QfeSet = Nothing
    Set Service = Nothing
    Set Locator = Nothing
End Sub

2012年12月12日水曜日

[ExcelVBA] Gotoを使おう!


アドベントカレンダー 12日目

みなさーん。Goto使ってますかぁ〜♪
はい。じゃんじゃん使ってますね。

いやー便利便利。
Goto使わないとかないですよねぇ。

とかいうと、
スパゲッティーつくりたきゃ、料理人になれよ!
と罵声を浴びてしまいそうになりますが・・・

javascriptならbreak, continue
perlならlast, next
vb.netでさえexit, continue

などがあるというのに…
残念ながらVBAでは次のループへに該当するものがない…
そこでgotoを変わりに使おうよ。
って話ですよ。

するとね。
gotoなんてスパゲッティーの温床!
gotoなんて使わずに表現できるからそうしなさい!
なんて言うわけですよ。

あの・・・
本来のあるべきコードの解釈をねじまげてまで、
gotoを使わないことに必死になることはないと思うんですよね。
そもそも、にっくきはスパゲッティーなコーディングなわけであって
他の言語のループ制御と同等の使い方と限定したならば
特に問題は発生しないと思うんですけどね。

例えば、ファイルを開き1行ずつ処理する場合
開く→1行データ取得→必要データか判定→必要データを所定の処理をして取得
と考えた場合以下のようにかける。
ポイントは、不要データのコードがかかれている部分
必要データのコードが書かれている部分がネストされることなく
はっきりとわかるようになっていること。

Sub SampleCode(ByVal FilePath As String)
    Dim FSO     As Object
    Dim FH      As Object
    Dim OneLine As String
    
    '** Objectの生成 **
    Set FSO = CreateObject("Scripting.FileSystemObject")
    
    
    Set FH = FSO.OPenTextFile(DataFilePath, 1)
    
    Do While Not .AtEndOfStream
        '■1行ずつ取得する
        OneLine = .ReadLine
    
        '■特定の条件を満たさない行はデータとして取得しない
        '空行は次のループへ
        If Trim(OneLine) = "" Then GoTo NextDoLoop
        
        '○○を含む行はヘッダー行なので除外する
        If 0 < InStr(OneLine, "○○") Then GoTo NextDoLoop
        
        '××を含む行はフッター行なので除外する
        If 0 < InStr(OneLine, "××") Then GoTo NextDoLoop
        
        
        '■上記で除外すべきデータを除いているので
        '  ○×△なデータだけになっている
        
        '以下いろんな処理
        
NextDoLoop:
    Loop
    
    FH.Close
    
    Set FH = Nothing
    Set FSO = Nothing
End Sub
可読性を犠牲にしてまで、スパゲッティー呪文に取り憑かれて つかわないようにするのはどうなんだろうねぇ。。 と思う今日この頃でした。

2012年12月11日火曜日

[ExcelVBA] PCロックの妨害


アドベントカレンダー 11日目

コンプラの関係で離席する時は、パソコンにロックをしなさいと口うるさくなる今日この頃。
一定の操作がないとするロックがかかるような設定になったりとコンプラさまさまなわけですが…

ときおり、一部の人だけコードが動かないなんてことがおきるもんだから
その人の環境で調査するため、ログインされた状態で引き渡してもらうのですが
上記理由から、すぐにロックがかかったりするわけですよね。
もちろん、システムなんていじれないようにされてるので、
そうなると、なんかのキーを送信すりゃいいじゃん!
となるのでこうなった。
Option Explicit

Sub SampleCode()
    Dim WSH As Object
    Set WSH = CreateObject("Wscript.Shell")
    
    Do
        WSH.SendKeys "^"
        DoEvents
    Loop
    
    Set WSH = Nothing
End Sub

ひとまず、Ctrlを送信。
これだけでも、十分なんだけど、
これだと、実行しているのか止まっているのか不明なので
もうちょっと視認性を高めるとして、オートシェイプを追加して…
ボタンでスタート/ストップできるようにしてみると。
Option Explicit
Private Declare Sub Sleep Lib "Kernel32" (ByVal dwMilliseconds As Long)

Dim Flag As Boolean
Sub ToggleButton()
    Dim ToggleName As String
    ToggleName = Shapes("Button").TextFrame.Characters.Text
    
    If ToggleName = "スタート" Then
        Shapes("Button").TextFrame.Characters.Text = "ストップ"
        Flag = False
        Call Loooooop
    Else
        Shapes("Button").TextFrame.Characters.Text = "スタート"
        Flag = True
    End If
End Sub


Sub Loooooop()
    Dim WSH As Object

    '** Objectの生成 **
    Set WSH = CreateObject("Wscript.Shell")

    Flag = False

    Do
        If Flag Then Exit Do
        WSH.SendKeys "^"
        Range("B1") = Time
        DoEvents
        Sleep (100)
    Loop
    
    Set WSH = Nothing
    MsgBox "停止"
End Sub

2012年12月9日日曜日

[ExcelVBA] 省略記法


アドベントカレンダー 9日目

連想配列好きな人は、Dictionaryオブジェクトをガンガン使っているとおもいますが
DictionaryオブジェクトのItemは省略して書くことができますよ。

Option Explicit

Sub SampleCode()
    Dim DicObj As Object
    Set DicObj = CreateObject("Scripting.Dictionary")

    DicObj.Add "First", CreateObject("Scripting.Dictionary")
    DicObj.Item("First").Add "Second", CreateObject("Scripting.Dictionary")
    DicObj.Item("First").Item("Second").Add "Third", CreateObject("Scripting.Dictionary")
    DicObj.Item("First").Item("Second").Item("Third").Add "Fourth", CreateObject("Scripting.Dictionary")
    DicObj.Item("First").Item("Second").Item("Third").Item("Fourth").Add "Fifth", "ok"
    
    Debug.Print DicObj.Item("First").Item("Second").Item("Third").Item("Fourth").Item("Fifth")
    Set DicObj = Nothing
End Sub

これをItemを省略して書くと…
Option Explicit

Sub SampleCode()
    Dim DicObj As Object
    Set DicObj = CreateObject("Scripting.Dictionary")

    DicObj.Add "First", CreateObject("Scripting.Dictionary")
    DicObj("First").Add "Second", CreateObject("Scripting.Dictionary")
    DicObj("First")("Second").Add "Third", CreateObject("Scripting.Dictionary")
    DicObj("First")("Second")("Third").Add "Fourth", CreateObject("Scripting.Dictionary")
    DicObj("First")("Second")("Third")("Fourth").Add "Fifth", "ok"
    
    Debug.Print DicObj("First")("Second")("Third")("Fourth")("Fifth")
    Set DicObj = Nothing
End Sub

見慣れない人には、わかりづらいかもしれませんが、
深い階層になった時横に長くなってみづらいことは
まぁまぁあるんで、そういう時とかのためにも.Itemを省略した
書き方に慣れてしまうのも一つの手なのかもしれませんね。

ちなみに、Collectionの.Itemは省略すると叱られます。

[ExcelVBA] 背景色の設定


アドベントカレンダー 10日目



見た目ってどうしてます?
ExcelってどうがんばってもMicrosoft的カラーリングから抜け出しにくいですよね。
くすんだ灰色とか、微妙なパステルカラーとか・・・

もっと自由な色を使いたい!
なんて方もいるんではないでしょうか?

となると、あれを使うか…
と思うわけですよね。
あれです。


えっと、Excelのメニューバーの
ツール→オプション→色の…
なんてベタなことはいいませんよ 笑

たまにゃ違った方法をお勧めしてみますか。
では、コントロールツールボックスでも使いましょう。



Microsoft Office Spreadsheetを選択します。
ドラッグしてSpreadsheetコントロールを配置します。

Spreadsheet内のエクセルはデフォルトの状態でも
カラーパレットの数も多く以下のようにため息しかでない
色がいっぱい登録されています。



ユーザー設定を押せばRGBで設定も可能です。

例えば、こんなデザインだったり…


(ごめんなさい。自分にはデザインセンスがないです・・・)

デザインセンスのある方ならもっと綺麗に作り込めそうですねっ!


そうそう。
ここまでは冗談話として、
好きな色を設定したい時は、
RangeObj.Interior.Color = RGB(R値, G値, B値)
RangeObj.Font.Color = RGB(R値, G値, B値)
とすればいよ。

あ、それからSpreadSheetってセル内で改行ができないみたい・・・

2012年12月8日土曜日

[ExcelVBA] 浮動小数点問題


アドベントカレンダー 8日目

たまには、こんなネタも。
45.2 - 38.8 はいくつでしょうか?
では、計算してみましょう。
Option Explicit

Sub SampleCode()
    Dim a As Double
    Dim b As Double
    
    a = 45.2
    b = 38.8
    
    Debug.Print a - b
End Sub

結果は
6.40000000000001
です。

こんなに簡単んそうな計算結果でも誤差が出てしまいます。
これは、IEEE 754という数値計算の標準規格を利用しているものなら
全て発生する問題だそうで、詳細を知りたい場合は以下サイトなんかを
眺めるとよいと思います。

第4回 演算誤差の正体

2012年12月7日金曜日

[ExcelVBA] 名前をつけて保存的なことをしたい


アドベントカレンダー 7日目

こんなシチュエーションありませんか?
それは、マクロを実行した結果を別名で保存したい時。
しかも、ユーザー自身が保存場所を選択して、そこへ保存する場合です。


ファイルの中身をうっかり変更されてしまうのを防ぐために
読み取り専用にして使っているケースは多いと思うのですが
マクロで作成したデータを保存してもらうために
わざわざ、ユーザー自身がメニューバーのファイルにある
名前をつけて保存を選択して保存をしてもらうのはちょっぴりいまいち感でいっぱいですよね!

そこは、「保存する」ボタンを用意してあげて
プログラム側で処理してあげましょう。

Option Explicit

Sub SampleCode()
    Dim FileName As String
    
    FileName = Application.GetSaveAsFilename
    
    If FileName <> "False" Then
        ActiveWorkbook.SaveAs FileName:=FileName
    End If
    
End Sub
6行目のApplication.GetSaveAsFilenameを実行したら「名前を付けて保存」の画面が立ち上がります。
ここでキャンセルを押されるとFalseの文字列が返してきます。
なので、ファイル名を指定して保存を押した場合は、フルパスが返ってきます。
よって、フルパスの場合、ドライブ名で始まるか、ネットワーク上なら¥¥で始まるため
"False"だけの場合、キャンセルを押されたと判断できます。

8行目は、キャンセルだった場合、別名保存をしないための処理を行なっています。
9行目は、別名保存しているだけです。

また、「名前を付けて保存」の初期フォルダ位置を変更したい時は、
InitialFileNameにパスを指定すればOKです。
例えば、c:ドライブ直下の場合は以下の通り。
Option Explicit

Sub SampleCode()
    Dim FileName As String
    
    FileName = Application.GetSaveAsFilename(InitialFileName:="c:\")
    
    If FileName <> "False" Then
        ActiveWorkbook.SaveAs FileName:=FileName
    End If
    
End Sub

ファイルのタイプを指定したい場合は、
FileFilterにファイルのタイプを指定します。
Option Explicit

Sub SampleCode()
    Dim FileName As String
    
    FileName = Application.GetSaveAsFilename(InitialFileName:="c:\", FileFilter:="画像ファイル (*.jpg),*.jpg")
    
    If FileName <> "False" Then
        ActiveWorkbook.SaveAs FileName:=FileName
    End If
    
End Sub