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

cj_mover · ベストアンサー

＃７-９です。

> すみませんが、このご回答への補足ではありません。
> If InStr(StrConv(Cells(i, "B"), vbNarrow), "B") > 0 Or _
> InStr(StrConv(Cells(i, "B"), vbNarrow), "G") > 0 Then
> をLike演算子でやってみました。
...
> もっと早くなりました。
> Likeの使い方、あってますでしょうか？

Like 演算子の使い方はバッチリです。自信持っていいですよ。

速さを意識しての書換えということでしたら、
「同じ記述を繰り返さない」為に変数の使い方を工夫しましょう。
　　StrConv(Cells(i, "B"), vbNarrow)
という記述の内、特に
　　Cells(i, "B")
のようなセル参照には時間が掛かるもの、
という意識を持つようにすると、効率的な記述が出来るようになります。
（InStrと比べて）"もっと早くなりました。"という結果の違いも
実はセル参照の数の違いが原因であって、構文の問題ではないですね。
試しに以上説明のように変数の扱いだけ書き換えてみましたが、
こちらのダミーデータでは、＃９補足欄のマクロをさらに４割ほど時短できました。
もし興味あるようでしたら、InStr版の方も第一引数に文字列型変数を指定するように書ければ、
セルの文字列値を全桁ループするよりは１～２割速くなる筈です。

その他の記述については、かなりのレベルで書けていると思います。

Like 演算子（というよりパターンマッチング全般）は、比較的処理が遅いので、
Like "*[BG]####*"の代りにIsNumeric()とLen()を組み合わせて、
同等の仕様を実現するのも（試してませんが）有望と思いますが、
記述を複雑にするよりは、Like 演算子の「シンプルに書ける」特長を活かした方が
いいのかも知れませんね。

以下、＃９補足欄のマクロについて変数の扱いだけ書き換えたものです。

' ' ==================================================
Sub ReSample3TEST()
Dim i As Long, k As Long, buf As String, str As String, time1 As Single
time1 = Timer
　　Application.ScreenUpdating = False
　　For i = 1 To Cells(Rows.Count, "B").End(xlUp).Row
　　　　buf = StrConv(Cells(i, "B"), vbNarrow)
　　　　If buf Like "*[BG]####*" Then
　　　　　　For k = 1 To Len(Cells(i, "B"))
　　　　　　　　str = Mid$(buf, k, 5)
　　　　　　　　If str Like "[BG]####" Then
　　　　　　　　　　Cells(i, "D") = str
　　　　　　　　　　Exit For
　　　　　　　　End If
　　　　　　Next k
　　　　End If
　　Next i
　　Application.ScreenUpdating = True
MsgBox Format(Timer - time1, "0.0000秒")
End Sub
' ' ==================================================

蛇足ですが、＃９の配列変数版についてです。
（特に明言されていませんが多分）
１つにセルに付き１つの対象文字列を取り出せば十分、
という条件のようなので、それに合わせて
ほぼ＃９補足欄のマクロ同等の仕様で書き直しておきます。
今すぐは解らなくても構いませんし、見送って貰っていいと思いますが、
速さの為の方法として配列変数は結構有力なので、
いつか何かの参考になればと思っています。
（NMin()関数は＃９のままです）

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

Sub Re8819211j1stTerm()
Dim mtxS()
Dim mtxP()
Dim sTmp As String
Dim s As String
Dim nUBY As Long
Dim nPB As Long
Dim nPG As Long
Dim nPos As Long
Dim i As Long
Dim t As Single: t = Timer

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

　　For i = 1 To nUBY　'　行（Y）方向にインクリメント
　　　　sTmp = StrConv(mtxS(i, 1), vbNarrow) '　各セルの値
　　　　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"の何れかが見つかったならば
　　　　　　　　s = Mid$(sTmp, nPos, 5)
　　　　　　　　If s Like "[BG]####" Then　'　"B"、"G"に続く４桁が数字文字列ならば
　　　　　　　　　　mtxP(i, 1) = s　'　マッチした文字列を出力用二次元配列に格納
　　　　　　　　End If
　　　　　　Else　'　"B"、"G"が見つからないなら
　　　　　　　　Exit Do　'　Doループを抜け次のセルへ
　　　　　　End If
　　　　Loop
　　Next i

　　Application.ScreenUpdating = False
'　　Application.Calculation = xlCalculationManual
　　Cells(1, "K").Resize(nUBY, 1).Value = mtxP　'　出力用二次元配列をサイズを合わせたセル範囲に出力
　　Application.ScreenUpdating = True
'　　Application.Calculation = xlCalculationAutomatic
'　　Erase mtxS(), mtxP()
MsgBox "j1stTerm：" & Format(Timer - t, "0.0000秒")
End Sub
' ' ==================================================

お礼

Sub ReSample3TEST() 素晴らしく早いです。
内容もよく理解できますので助かります。
ありがとうございました。
そして配列変数版、これは驚異的な早さですね！
1万件が0.0625秒！
これは配列を使わない手はないですね。

Sub Sample4TEST()
Dim i As Long, x As Long, k As Long, str As String, buf As String, time1 As Single
Dim myW, myX
time1 = Timer
x = Cells(Rows.Count, "B").End(xlUp).Row
myW = Range(Cells(1, "B"), Cells(x, "B")).Value
ReDim myX(1 To x)
For i = 1 To x
buf = StrConv(myW(i, 1), vbNarrow)
If buf Like "*[BG]####*" Then
For k = 1 To Len(myW(i, 1))
str = Mid$(buf, k, 5)
If str Like "[BG]####" Then
myX(i) = str
Exit For
End If
Next k
End If
Next i
Application.ScreenUpdating = False
Range("D1").Resize(x, 1).Value = Application.Transpose(myX)
Application.ScreenUpdating = True
MsgBox Format(Timer - time1, "0.0000秒")
End Sub

としてみました。
これも0.0625秒でした。今回もたくさんたくさんありがとうございました！