セルの長文を、正規表現で連続してマッチング

備考欄に
@@高速代=850円、##高速代=850円

というデータがあり、@@がドライバーへの支払 で　## が利用者への受領としてデータが作られています。これを分類して請求書と支払書をExcelのVBA で作りたいのです。

データが、受領と支払それぞれ1個づつなら
http://kenlog.net/excel-vba-macro-pattern-matchi …
などを参考にして、

strPattern = "##.+=(\d+)円、*"　というように正規表現で抜き出し、隣のセルに一行ごとに入れるというのは作れそうだなと思いましたが、


@@高速代=850円、@@駐車場=600円、##高速代=850円、##駐車場=600円
のようになっている箇所が若干あり困っています。

繰り返し処理でどう書いていいのかわからず困っています。

この際、支払と受取の@@と##の要素は今後、各データマックス２こづつまでと決めて作り込みしようと思うのですが、繰り返し処理して、備考欄の次に4列書き出し方法をお教え頂けたらと思います。

No.1 ベストアンサー 回答者： MarcoRossiItaly 回答日時： 2014/02/17 09:21

If の次の行に For ループを入れ子にして、for j = 1 to rematch.count と書き、cells(i, j+1).value = rematch(j-1) といった感じで抜き出せるでしょう。

パターンについて。「+」の直後に、「?」を付けます。こうすると、最短一致の文字列を取得します。付けないと、最長一致となり、1 個目の「##」から 10 個目の「円」までを抜き出してしまったりします。さらに、不要な括弧は除去して、

strPattern = "##.+?=\d+"

あるいは

strPattern = "##.+?=\d{1,3}(,\d{3})+"

で検索します。

なお、SubMatches コレクションは、パターン中の括弧の個数に応じた個数のメンバが作製されます。括弧がない場合は文字列を取得しないので、SubMatches にアクセスしようとすると、エラーになります。サブの括弧が 1 組なら SubMatches のインデックスは 0、2 組なら 0 と 1 という具合になります。

SubMatches が作製されなくても、検索された文字列は、reMatch（Matches コレクション）にアクセスすれば、各 Match オブジェクトに入っています。つまり reMatch(0)、reMatch(1) というふうにして取り出せます。

お示しのページ中の Global プロパティは勿論、True にしてください。そうでないと金額の個数に関係なく、常にマッチ数が 0 か 1 になってしまいます。

また、IgnoreCase プロパティの行がありますが、ここが True であれば大文字（upper case）と小文字（lower case）の区別を無視し（ignore）、False であれば無視しないということになります。その行のコメントの内容は逆になっているようなので、ご注意ください。

この回答へのお礼

vba のループの書き方が今ひとつわからず、ヒントを頂いて書きなおしてみました。

Sub RegExpSample()
Dim RE, reMatch
Dim strPattern As String
Dim i As Long
Dim objM
Dim j As Long
Dim msg As String
Dim matchString As String

Set RE = CreateObject("VBScript.RegExp")

strPattern = "(@@)[^0-9]+([0-9]+)円"

With RE
.Pattern = strPattern
.IgnoreCase = True '大文字と小文字を区別する
.Global = True '1回目のマッチで終了しない

For i = 1 To ActiveSheet.UsedRange.End(xlDown).Row 'データが有る最終行まで

Set reMatch = .Execute(Cells(i, 1)) 'A列で検索実行
If reMatch.Count > 0 Then

For j = 1 To reMatch.Count

Cells(i, j + 1).Value = reMatch(j - 1).subMatches(1) '検索パターンのグルーピング化[（）内]

Next j
End If

Next i
End With

Set reMatch = Nothing
Set RE = Nothing
End Sub

ただ、これだと空欄があるとそこで止まってしまうので、さらにif で囲んで　さらに作りこんでいきたいと思います。

ありがとうございました。

お礼日時：2014/02/20 00:48

No.4 回答者： WindFaller 回答日時： 2014/02/18 12:12

#3様　失礼しました。

>「.+?」というパターン

今、VBAで、試してみました。
以前のバージョンのRegExpでは、Perlライクの方法は効かなかった記憶があったので、
やむを得ず、

[^=]+

という方法を使いました。この方法で、正しくヒットしました。

いずれにしても、#2で書かれたマクロは、単に試験的なものですから、
後は、ご質問者さんが、どう対応するか待ちますが、こちらは、再び、回答出来るかは、確約できないのが辛いところです。

この回答へのお礼

ありがとうございます。やっと、今日時間が取れましたので、今からいろいろやってみたいと思います。　片手間にやっておりまして、すぐお礼できずすみません。報告したいと思います。

お礼日時：2014/02/19 15:37

No.3 回答者： MarcoRossiItaly 回答日時： 2014/02/17 17:15

「.+?」というパターンに対して疑問が呈されているようですので、MSDN のページをご参考に掲載します。

これが証拠になるかは分かりませんが、少なくとも同じページ内には、「VBScript」の名前が載っている表が掲載されています。

その次の表には「?」が 2 回、登場するのですが、2 つ目のほうをご覧ください。「できるだけ少ない文字列と一致します」などと説明されています。

参考URL：http://msdn.microsoft.com/ja-jp/library/cc392020 …

この回答へのお礼

ありがとうございます。やっと、今日時間が取れましたので、今からいろいろやってみたいと思います。

お礼日時：2014/02/19 15:37

No.2 回答者： WindFaller 回答日時： 2014/02/17 16:04

こんにちは。

>@@高速代=850円、@@駐車場=600円、##高速代=850円、##駐車場=600円
これが、１セルに入っているという意味でしょうか。
実際のデータがどのようになっているのか分からないので、当て推量です。

見た範囲では、別に、とりわけ正規表現は必要ないような気がします。
というか、正規表現は、ヒットした順に出力されますので、高速代がない場合は、0円と入っている必要があります。

だから、コードは、kenlog.net を参考にはしましたが、以下のコードには、少し問題があります。
正規表現は、あくまでも、「、」のセパレータや「円」など、特定の文字が設定されていない時に役に立つのかなっていう感じです。

以下は、あくまでも、VBScript.Exp の文字列パターンです。
VBScript の正規表現に、先読みとか言ったような気がしますが、「.+?」というのはなかったと思います。

これを参考にしてみてください。ただ、配列変数を使わなくても可能です。

'//
'数字だけの取り出し。欠陥あり
Sub RegExpSample1()
　Dim RE As Object
　Dim Matches As Object
　Dim strPattern As String
　Dim c As Range
　Dim i As Long
　Dim cnt As Long
　Dim ary(3) As Variant
　cnt = 1　'セルのカウンタ
　Set RE = CreateObject("VBScript.RegExp")

　'数字だけの取り出し
　'strPattern = "[^=]+=(\d{0,3}(,?\d{1,3})+)"　'正規表現パターン
　'[,]がなくても、あっても対応可
　With RE
　　.Pattern = strPattern
　　.Global = True
　　For Each c In Range("A1:A10")
　　　If c <> "" And InStr(1, c.Value, "=") > 0 Then
　　　　Set Matches = .Execute(c.Value)
　　　　For i = 0 To Matches.Count - 1
　　　　　 ary(i) = Matches(i).SubMatches(0)　'配列に代入
　　　　Next i
　　　　'2列目から
　　　　Cells(cnt, 2).Resize(, UBound(ary()) + 1).Value = ary()
　　　　Erase ary()
　　　　cnt = cnt + 1
　　　End If
　　Next c
　End With
　Set Matches = Nothing
　Set RE = Nothing
End Sub
'//
'//
'文字列を含む数字の取り出し、円付き
Sub RegExpSample2()
　Dim RE As Object
　Dim Matches As Object
　Dim strPattern As String
　Dim c As Range
　Dim i As Long
　Dim cnt As Long
　Dim ary(3) As Variant
　cnt = 1
　Set RE = CreateObject("VBScript.RegExp")

　'記号を除く文字と数字と円
　strPattern = "[^=@#円]+=\d{0,3}(,?\d{1,3})+円"
　
　With RE
　　.Pattern = strPattern
　　.Global = True
　　For Each c In Range("A1:A10")
　　　If c <> "" And InStr(1, c.Value, "=") > 0 Then
　　　　Set Matches = .Execute(c.Value)
　　　　For i = 0 To Matches.Count - 1
　　　　　 ary(i) = Matches(i).Value
　　　　Next i
　　　　'2列目から
　　　　Cells(cnt, 2).Resize(, UBound(ary()) + 1).Value = ary()
　　　　Erase ary()
　　　　cnt = cnt + 1
　　　End If
　　Next c
　End With
　Set Matches = Nothing
End Sub
'//

この回答へのお礼

ありがとうございます。ちょっと難しくてわからなかったのですが、こういう書き方もあるのだと参考になりました。

お礼日時：2014/02/20 00:52