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

cj_mover

＃７-８です。

もう一例挙げておきます。
配列変数を使って、読み易さや解り易さや字数の少なさよりも処理速度を優先した書き方です。
私個人は最も得意とする慣れた書き方ですが、質問掲示板ではあまり受けがよくないんですよね。

条件（サンプルの作り方）によっては、一万件程度でも、
正規表現で一括置換するよりも、処理が速い場合もあります。
外部オブジェクトを使うよりは配列変数の方が技術的に難しく感じないのかなぁ、と思いました。

技術的な補足として、
★の部分の判別の仕方と関数の内容は、Sub Re8819211a改()に応用すれば４割位時短になります。

数多くなり過ぎて大変になっちゃったらスミマセン。
私の意図としては、これも挙げておいた方が、そちらで選ぶ基準が持ち易いのでは？と。
今から数日、また返信出来ませんが、それでも補足あれば必ずチェックしますので。

' ' ==========配列変数版==============================

Sub Re8819211j()
Dim mtxS()
Dim mtxP()
Dim sTmp As String
Dim nUBY As Long
Dim nUBX As Long
Dim nPB As Long
Dim nPG As Long
Dim nPos As Long
Dim nX As Long
Dim i As Long

　　mtxS = Range("B1:B" & Cells(Rows.Count, "B").End(xlUp).Row).Value　'　元データを二次元配列として取得◆セル範囲を指定
　　nUBY = UBound(mtxS)　'　行数（YSize）を取得
　　ReDim mtxP(1 To nUBY, 1 To 5)　'　出力用二次元配列をリサイズ◆列数（XSize）を仮に５で指定

　　For i = 1 To nUBY　'　行（Y）方向にインクリメント
　　　　sTmp = mtxS(i, 1)　'　各セルの値
　　　　nX = 0　'　列（X）位置を初期化
　　　　Do　'　Doループ（"B"、"G"が見つからなくなるまで文字列の桁位置を検索）
　　　　　　nPB = InStr(nPos + 1, sTmp, "B")　'　"B"が見つかる桁位置
　　　　　　nPG = InStr(nPos + 1, sTmp, "G")　'　"G"が見つかる桁位置
　　　　　　nPos = NMin(nPB, nPG)　'　"B"、"G"の内先に見つかった桁位置（関数解説参照）
　　　　　　If nPos Then　'　"B"、"G"の何れかが見つかったならば
　　　　　　　　If IsNumeric(Mid$(sTmp, nPos + 1, 4)) Then '　"B"、"G"に続く４桁が数字文字列ならば★
　　　　　　　　　　nX = nX + 1　'　列（X）位置送り
　　　　　　　　　　mtxP(i, nX) = Mid$(sTmp, nPos, 5)　'　マッチした文字列を出力用二次元配列に格納
　　　　　　　　End If
　　　　　　Else　'　"B"、"G"が見つからないなら
　　　　　　　　Exit Do　'　Doループを抜け次のセルへ
　　　　　　End If
　　　　Loop
　　　　If nX > nUBX Then nUBX = nX　'　列数（XSize）の最大値を更新
　　Next i

　　ReDim Preserve mtxP(1 To nUBY, 1 To nUBX)　'　出力用二次元配列を列数（XSize）の最大値に合わせてリサイズ
　　Application.ScreenUpdating = False
　　Application.Calculation = xlCalculationManual
　　Cells(1, "K").Resize(nUBY, nUBX).Value = mtxP　'　出力用二次元配列をサイズを合わせたセル範囲に出力
　　Application.ScreenUpdating = True
　　Application.Calculation = xlCalculationAutomatic
　　Erase mtxS(), mtxP()
End Sub

' ' /// ２つの非負整数の内　最少の自然数（0以外の最少数）を返す。
' ' /// ２つの非負整数の両方が0ならば0を返す。
Private Function NMin(ByVal n1 As Long, ByVal n2 As Long) As Long
　　If n1 = 0 Then
　　　　NMin = n2
　　ElseIf n2 = 0 Then
　　　　NMin = n1
　　ElseIf n1 > n2 Then
　　　　NMin = n2
　　Else
　　　　NMin = n1
　　End If
End Function

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

お礼

勉強させていただきます。
何度もご親切にありがとうございました。

補足

すみませんが、このご回答への補足ではありません。
If InStr(StrConv(Cells(i, "B"), vbNarrow), "B") > 0 Or _
InStr(StrConv(Cells(i, "B"), vbNarrow), "G") > 0 Then
をLike演算子でやってみました。

Sub Sample3TEST()
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 StrConv(Cells(i, "B"), vbNarrow) Like "*[BG]####*" Then
For k = 1 To Len(Cells(i, "B"))
str = Mid$(StrConv(Cells(i, "B"), vbNarrow), k, 5)
If str Like "[BG]####" Then
Cells(i, "D") = Mid$(StrConv(Cells(i, "B"), vbNarrow), k, 5)
Exit For
End If
Next k
End If
Next i
Application.ScreenUpdating = True
MsgBox Format(Timer - time1, "0.0000秒")
End Sub

もっと早くなりました。
Likeの使い方、あってますでしょうか？