EXCEL VBA 文字列

質問

下記のソースの場合、一つのセル（例えばA1）に【鈴木　太郎】とあれば、隣のセル（B1）に"鈴木　太郎"と表示されます。
（これを一つのセルに【鈴木　太郎】【佐藤　太郎】【伊藤　太郎】とあった場合は、"鈴木　太郎】【佐藤　太郎】【伊藤　太郎"と表示されます。）

例えば、C1には【鈴木　太郎】【佐藤　太郎】【伊藤　太郎】とあった場合には、C2には"鈴木　太郎"、D2に"佐藤　太郎"、E2に"伊藤　太郎"とすることは可能でしょうか？
※行によって異なり、【○○　○○】はいくつあるとは限らないとします。

よろしくお願いいたします。

Sub PickupWords()
　Dim Matches As Object
　Dim Match As Object
　Dim buf As String
　Dim c As Variant
　With CreateObject("VBScript.RegExp")
　　.Pattern = "【(.+)】"
　　.Global = False
　　Application.ScreenUpdating = False
　　For Each c In Range("A1", Cells(Rows.Count, 1).End(xlUp))
　　　If .Test(c.Value) Then
　　　　buf = c.Value
　　　　Set Matches = .Execute(buf)
　　　c.Offset(, 1).Value = Matches.Item(0).SubMatches(0) '括弧の中を取り出す
　　　End If
　　Next c
　　Application.ScreenUpdating = True
　End With
End Sub

回答No.5

tom04

こんばんは！
横からお邪魔します。

＞例えば、C1には【鈴木　太郎】【佐藤　太郎】【伊藤　太郎】とあった場合には、
＞C2には"鈴木　太郎"、D2に"佐藤　太郎"、E2に"伊藤　太郎"とすることは可能でしょうか？
＞※行によって異なり、【○○　○○】はいくつあるとは限らないとします

特に最後の※印の条件があるというコトは、C1セルからC列の最終行まで同様の表示を行いたい！
というように解釈しました。
というコトはC2セル・D2セル・・・という表示ではまずいと思いますので、
勝手にその行のD列以降に表示するようにしています。
一例です。
データはC列の1行目からあるとします。

Sub Sample1()
Dim i As Long, k As Long, tmp, myArray
For i = 1 To Cells(Rows.Count, 3).End(xlUp).Row
If InStr(Cells(i, 3), "】【") > 0 Then
myArray = Split(Cells(i, 3), "】【")
For k = 0 To UBound(myArray)
tmp = myArray(k)
Cells(i, 4 + k) = Replace(Replace(tmp, "【", ""), "】", "")
Next k
Else
Cells(i, 4) = Replace(Replace(Cells(i, 3), "【", ""), "】", "")
End If
Next i
End Sub

こんな感じではどうでしょうか？m(_ _)m

回答No.4

mitarashi

#1です。
ヒントしか出しておりませんので、そのまま実行してもご期待の動作にはなりません。
一日経って独力でアレンジされたかもしれませんが、一応完成版？を投稿しておきます。
Sub PickupWords()
Dim Matches As Object
Dim buf As String
Dim c As Variant
Dim i As Long

With CreateObject("VBScript.RegExp")
.Pattern = "【(.+?)】"
.Global = True
Application.ScreenUpdating = False
For Each c In Range("A1", Cells(Rows.Count, 1).End(xlUp))
If .Test(c.Value) Then
buf = c.Value
Set Matches = .Execute(buf)
For i = 0 To Matches.Count - 1
c.Offset(, i + 1).Value = Matches.Item(i).SubMatches(0) '括弧の中を取り出す
Next i
End If
Next c
Application.ScreenUpdating = True
End With
End Sub

なお、Dim c As range とする方が、インテリセンスが効いて便利だと思います。

回答No.3

Nouble

ちょっとやり方だけで良いですか？
僕の思いついた誤解を参考にどうぞ

対象セル領域を何らかのRangeオブジェクトに入れておいて
調査セルにスポットを当てます。
このスポットの当たった領域を仮に「着目点」と読みます。

まず「【」が何文字になるか調べておき、覚えさせておきます。
ここで、着目点から「【」をリプレースした時の文字数を取得し、着目点の文字数から引きます。
上記の減損した文字数を、先の「【」の文字数で割って一加えると、
その着目点に含まれる単語数が解ります。

次に、着目点について何文字目に「【」と「】」が含まれるか調べます。
あとはその解った文字位置の間を切り出してRange変数の該当域に書き込み、
最終行まで調べ上げた後に、セル域に書き出せば　良い様に思います。

駄目ですかね？

お役に立てていたならば幸いです。

回答No.2

K Kazz（@JazzCorp）

'A列のセルから【】内の文字列をB列以降に切り出す
Option Explicit
Sub PickupWords()
Dim Matches As Object
Dim Match As Object
Dim c As Variant
Dim kk As Long
Dim nn As Long
With ActiveSheet.UsedRange
kk = .Columns.Count
.Offset(, 1).Resize(.Rows.Count, .Columns.Count - 1).ClearContents
End With
With CreateObject("VBScript.RegExp")
.Pattern = "【(.+?)】"
.Global = True
For Each c In Range("A1", Cells(Rows.Count, 1).End(xlUp))
' If (.Test(c.Value)) Then
Set Matches = .Execute(c.Value)
nn = Matches.Count
kk = 0
For Each Match In Matches
kk = kk + 1
c.Offset(, kk).Value = Trim(Match.submatches(0)) '括弧の中を取り出す
Debug.Print Match.submatches(0)
Next
' End If
Next
End With
kk = ActiveSheet.UsedRange.Columns.Count
Range(Columns(2), Columns(kk)).AutoFit
Set Matches = Nothing
Application.ScreenUpdating = True
End Sub

回答No.1

mitarashi

日曜日をhtmlソースのTable解析に費やしていて、ちょうど正規表現を復習していました。夜も更けたのでさわりだけ回答いたします。
控えめマッチングの「?」と、.Global=Trueがポイントです。ご参考まで。
Sub PickupWords()
Dim Matches As Object
Dim Match As Object
Dim buf As String
With CreateObject("VBScript.RegExp")
.Pattern = "【(.+?)】"
.Global = True
buf = "【鈴木　太郎】【佐藤　太郎】【伊藤　太郎】"
Set Matches = .Execute(buf)
For Each Match In Matches
Debug.Print Match.submatches(0)
Next Match
End With
End Sub

補足

buf = "【鈴木　太郎】【佐藤　太郎】【伊藤　太郎】"
は、どいうことでしょうか？

うまくいきません・・・