エクセル2010で規則性のある文字列の取り出し

質問

エクセルでこんなことができますか？
1つのセルに文字列が入力されています。
例えば、
B1セル　2014/11/09配布B1234確認あり。
B2セル　G4321
B3セル　B5セル　未確認。ただしB0025と同様の形態と思われる。
B4セル　完了。確認済み
B5セル　空白
B6セル　G0125
B7セル　確認済みG6655資料送付済み

等々、まちまちです。
このデータから、BまたはGで始まる数字4桁を
B1234
G4321
B0025
のようなかたちで取り出したいのです。
どのような方法があるでしょうか？
関数でもVBAでもかまいません。教えてください。

回答No.8

cj_mover

＃７、ｃｊです。
全体を読み返して気が付いたことがあるので、追加自己レスです。
マクロは２例とも差し替えになります。

> マッチした位置情報に意味は ...
質問文からは読み取れませんでしたが、
元データと同じ行位置に結果を出力したい、ということのようなので、
書き直しました。
事前に想定はしていませんでしたが、少しの修正で済みました。

' ' ==========簡易簡潔版==============================

Sub Re8819211a改()
Dim c As Range
Dim sTmp As String
Dim nPos As Long
Dim cn As Long
　　Application.ScreenUpdating = False

　　For Each c In Range("B1:B" & Cells(Rows.Count, "B").End(xlUp).Row)　'　セル範囲を総当たりループ
　　　　sTmp = c　'　セル値を文字列変数に
'　　　　nPos = 0
　　　　cn = 0
　　　　Do　'　Doループ（"B"、"G"が見つからなくなるまで文字列の桁位置を検索）
　　　　　　nPos = NaturalMin(InStr(nPos + 1, sTmp, "B"), InStr(nPos + 1, sTmp, "G"))　'　関数解説参照
　　　　　　If nPos Then　'　"B"、"G"が見つかったならば
　　　　　　　　If Mid$(sTmp, nPos) Like "[BG]####*" Then　'　"B"、"G"から始まり数字が４桁続く文字列ならば
　　　　　　　　　　cn = cn + 1　'　ヒット数送り
　　　　　　　　　　Cells(c.Row, "K")(1, cn) = Mid$(sTmp, nPos, 5) '　マッチした文字列を出力
　　　　　　　　End If
　　　　　　Else　'　"B"、"G"が見つからないなら
　　　　　　　　Exit Do　'　Doループを抜け次のセルへ
　　　　　　End If
　　　　Loop
　　Next

　　Application.ScreenUpdating = True
End Sub

' ' /// ２つの引数の内　最少の自然数（0以外の最少数）を返す。
' ' /// ２つの引数の両方が0ならば0を返す。
Private Function NaturalMin(ByVal n1 As Long, ByVal n2 As Long) As Long
　　NaturalMin = Application.Min(n1, n2)
　　If NaturalMin = 0 Then NaturalMin = Application.Max(n1, n2)
End Function

' ' ==================================================

比較的処理が速い方の版については、記述内容としては寧ろ簡素になります。
ただ、
ひとつのセルに複数マッチした場合に、
単純にそれらを（区切り文字なしで）連結したものを出力するのが基本仕様です。
なので、複数列に分けて出力できるように、オマケを１０行書き足しました。
ひとつのセルに複数マッチすることは無い、と担保されていた場合でも、
オマケの記述以外は全く同じものになりますから、余計なコストは掛かっていません。
逆に複数マッチしても最初にマッチしたものだけを返すなんて条件も想像できますが、
少しの工夫で済みますし、後から処理するのでも難しくないですから、ここには書きません。
重複の削除については、元データと同じ行位置に結果を出力するならば不要でしょうし、
今回の書換えによって、ついでに処理するようには書けないので、ここには書きません。

' ' ==========一連文字列・正規表現・貼り付け版 =======

Sub Re8819211c改()
Dim oData As Object　'　As MSForms.DataObject
Dim oRE As Object　'　As VBScript_RegExp_55.RegExp　（正規表現）
Dim sSrc As String
　　Application.ScreenUpdating = False

　　Set oData = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")　'　New DataObject
　　Range("B:B").Copy　'　セル範囲（任意の列単位：複数列可）のコピーデータをクリップボードに
　　oData.GetFromClipboard　'　クリップボードのコピーデータをDataObjectに
　　sSrc = oData.GetText　'　（tab区切り）cr改行 セル範囲全体を 文字列値 として取得
　　sSrc = StrConv(sSrc, vbNarrow)　'　文字列値 半角を強制

　　Set oRE = CreateObject("VBScript.RegExp")　'　RegExpをセット
　　oRE.Global = True　'　RegExpのお約束
　　oRE.Pattern = "(([^\r]*?)([GB]\d{4})([^\r]*?)|[^\r]*)"　'　RegExpのマッチングパターン
　　sSrc = oRE.Replace(sSrc, "$3")　'　RegExpの置換（マッチする文字列以外を消す）
　　Set oRE = Nothing

' ' ---------- 結果を複数列に出力する場合は以下１０行イキ --------
'Dim arrS() As String
'Dim i As Long
'　　arrS = Split(sSrc, vbCr)
'　　For i = 0 To UBound(arrS())
'　　　　If Len(arrS(i)) > 5 Then
'　　　　　　arrS(i) = Format(arrS(i), "&&&&&" & Application.Rept(vbTab & "&&&&&", Len(arrS(i)) \ 5 - 1))
'　　　　End If
'　　Next i
'　　sSrc = Join(arrS(), vbCr)
'　　Erase arrS()
' ' --------------------------------------------------------------

　　oData.Clear　'　DataObjectの中身を一旦空に
　　oData.SetText sSrc, 1　'　DataObjectに処理済の文字列をセット
　　oData.PutInClipboard　'　DataObjectの中身をクリップボードに送る
　　Cells(1, "K").PasteSpecial　'　クリップボードの中身をセル範囲に貼り付け
　　Application.CutCopyMode = 0　'　コピーモードをキャンセル
　　Set oData = Nothing

　　Application.ScreenUpdating = True
End Sub

' ' ==================================================

尚、何れのマクロも、出力先の先頭をＫ１に指定してあります。
"K" の行の記述を運用に合わせて指定し直してください。

何かあれば補足欄に書いてみてください。
それでは。。。

お礼

何度もありがとうございます。
今回は、ご解説いただいたLike演算子を活用して

Sub Sample2TEST()
Dim i As Long, k As Long, str As String, time1 As Single
time1 = Timer
Application.ScreenUpdating = False
For i = 1 To Cells(Rows.Count, "B").End(xlUp).Row
If InStr(StrConv(Cells(i, "B"), vbNarrow), "B") > 0 Or _
InStr(StrConv(Cells(i, "B"), vbNarrow), "G") > 0 Then
For k = 1 To Len(Cells(i, "B"))
str = Mid(StrConv(Cells(i, "B"), vbNarrow), k, 1)
If str Like "[BG]" Then
If Mid(Cells(i, "B"), k + 1, 4) Like "####" Then
Cells(i, "D") = Mid(StrConv(Cells(i, "B"), vbNarrow), k, 5)
Exit For
End If
End If
Next k
End If
Next i
Application.ScreenUpdating = True
MsgBox Format(Timer - time1, "0.0000秒")
End Sub

とやってみることにしました。すみません。
また教えていた大方法は、じっくり勉強させていただいて身につけたいと思っております。
ありがとうございました。

補足

よく見直したら
str = Mid(StrConv(Cells(i, "B"), vbNarrow), k, 1)
If str Like "[BG]" Then
If Mid(Cells(i, "B"), k + 1, 4) Like "####" Then　は

str = Mid(StrConv(Cells(i, "B"), vbNarrow), k, 5)
If str Like "[BG]####" Then
でいけますよね？
理解不足ですみません。