エクセル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.7

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
　　　　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(cn, "K") = 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

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

マッチした位置情報に意味は無い前提ですから、
セルひとつずつループするのではなく、
セル範囲（の内の有意な範囲）全体をひとつの文字列として読込んでから、
処理する方が効率的で速くなります。
正規表現を使うのが楽ですし、記述自体は簡潔になります。
出力の仕方もセルひとつずつ出すよりは、
出力用の二次元配列を一度で出す方が速くなります。
Application系の抑止などは必要に応じて適宜追加してください。
（EnableEventsやCalculation等々）
オマケとして重複を除く場合の処理も書いてみました。

元データのセル範囲指定は（ひとつの連続範囲であれば）複数列でも構いません。
Range("B:B")のように列単位で大丈夫です。
ExcelのSUM関数のように、使ってない範囲は自動的に削ぎ落としてくれますので、、、。

' ' ==========一連文字列・正規表現・配列変数 版=======（大量データ向き）

Sub Re8819211c()

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

Dim vPt　'　出力用二次元配列
Dim oRE As Object　'　As VBScript_RegExp_55.RegExp　（正規表現）
Dim colM As Object　'　As VBScript_RegExp_55.MatchCollection
Dim oM As Object　'　As VBScript_RegExp_55.Match
Dim i As Long
　　Set oRE = CreateObject("VBScript.RegExp")　'　RegExpをセット
　　oRE.Global = True　'　RegExpのお約束
　　oRE.Pattern = "[GB]\d{4}"　'　RegExpのマッチングパターン
　　Set colM = oRE.Execute(sSrc)　'　RegExpのマッチング結果をコレクションとして取得
　　ReDim vP(1 To colM.Count, 0)　'　出力用二次元配列をリサイズ
　　For Each oM In colM　'　RegExpのMatchCollectionを総当たりループ
　　　　i = i + 1　'　インデックス送り
　　　　vP(i, 0) = oM　'　出力用二次元配列にマッチング結果を格納
　　Next
　　Set colM = Nothing
　　Set oRE = Nothing

' ' ---------- 重複を除く場合は以下８行イキ ------
'Dim oDict As Object　'　As Scripting.Dictionary
'Dim v
'　　Set oDict = CreateObject("Scripting.Dictionary")　'　Dictionaryをセット
'　　For Each v In vP　'　出力用二次元配列を総当たりループ
'　　　　oDict(v) = Empty　'　Dictionaryに重複を除いたデータを格納
'　　Next
'　　vP = Application.Transpose(oDict.Keys)　'　重複を除いたDictionaryのキー配列を行列変換したものを出力用二次元配列に
'　　Set oDict = Nothing
' ' ----------------------------------------------

　　Application.ScreenUpdating = False
　　Cells(1, "K").Resize(UBound(vP)).Value = vP　'　セル範囲に出力用二次元配列を出力
'　　Application.ScreenUpdating = True
End Sub

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

直接の返事が無いようなので、＃１補足の問題について軽く触れてみます。
Like 演算子のパターンに用いるキャラクターセットの記法ですが、
（要するに "[" と "]" の間の書き方）
　[BG}
のように間に何も挟まない（区切らない）のが正解です。
　[B G]　や　[B,G]
は間違いで、それぞれ、半角スペースやカンマを拾ってしまいます。
＃最近ベテラン回答者さんがうっかり書き間違えたのが広まってしまって（？）
＃半角スペースやカンマを挟むのが流行っているようですが、間違いは間違いです。
詳しいことは、Like 演算子のＶＢＡヘルプで確認してください。
覚える必要がある約物は、? * # [ ] ! だけでいいです、

以上です。

お礼

cj_mover さん、いつもご丁寧にお教えいただきありがとうございます。

>マッチした位置情報に意味は無い前提ですから、

大変申し訳ありません。
わたしが、前提となる条件をきちんと書いておかなかったためお手間をとらせてしまいました。

どのセルにあるかも必要だったのです。
Like演算子の解説もとても勉強にになりました。
今回はとても急いでおり、すでにNo1,6の方のご回答をもとに実装のテストを行っております。
すみませんでした。