エクセル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秒でした。今回もたくさんたくさんありがとうございました！

回答No.10

tom04

No.1・6です。

Like演算子の説明についてはNo.7～No.9さんがNo.7の回答内で詳しく説明してくださっています。
すなわちNo.1のLike演算子の使い方は間違っていました。

"[ ]"　で囲まれている文字にマッチするという意味になりますので、
"[BG]"でも同じ結果になるはずです。

色々使い方はありますが、私的には
"[0-9]"　のような感じで「範囲」での使い方をよくします。m(_ _)m

お礼

何度もありがとうございました。
テストを続けたところ、
If IsNumeric(Mid(Cells(i, "B"), k + 1, 4)) Then　では、BoeingB52のような、想定外の文言もヒットしてしまうことがわかりました。（数字が4つなくとも末尾であればIsnumericで対象になってしまい、B52を返します）
If Mid(Cells(i, "B"), k + 1, 4) Like "####" Thenでやってみました。

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

回答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の使い方、あってますでしょうか？

回答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
でいけますよね？
理解不足ですみません。

回答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の方のご回答をもとに実装のテストを行っております。
すみませんでした。

回答No.6

tom04

No.1です。

今回は「B」または「G」の二つ限定ですので、わざわざLike演算子を使う必要はなかったですね。

前回のコードはすべて消去し、↓のコードにしてみてください。

Sub Sample2()
Dim i As Long, k As Long, str As String
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 = "B" Or str = "G" Then
If IsNumeric(Mid(Cells(i, "B"), k + 1, 4)) Then
Cells(i, "C") = Mid(Cells(i, "B"), k, 5)
Exit For
End If
End If
Next k
End If
Next i
Application.ScreenUpdating = True
MsgBox "処理完了"
End Sub

※　データ量が1万程度あるというコトですので、すべてのセルをループさせるとかなりの時間を要しますので、
今回は「B」または「G」がないセルは飛ばすようにしてみました。
ただし、存在するセルは1文字ずつ舐めるように検索しています。
今度はどうでしょうか？m(_ _)m

お礼

すごいですね！
前回のはちょっと時間がかかったのですが今回のはあっというまに終わってしまいました！
コードも理解できました。勉強になります。

ところで
If str = "B" Or str = "G" Then　の部分を前回おしえていただいた、
If str Like "[BG]" Then　にしてみましたが、これも同じ結果を返しました。
Like "[B,G]" Then　にしてみても同じです。
Like演算子は存じてますが、カッコの使い方がよくわかりません。
よろしければご教示いただけませんでしょうか？

回答No.5

WindFaller

#4の回答者です。

>ただし、空白セルや該当なしのセルが飛ばされてしまうようで、元データと行があわなくなります。　
それは、作った時から、それは想定済みです。

>B1234
>G4321
>B0025
>のようなかたちで取り出したいのです。

#4では、あくまでも、#1さんのコードから、二つのコードを抽出することもあるという前提を優先させたからです。

'//
Sub Test1R()
　Dim objRe As Object
　Dim Matches As Object
　Dim c As Range
　Dim buf As String
　Dim i As Long
　Dim ar As Variant

　With CreateObject("VBScript.RegExp")
　　.Pattern = "([GB]\d{4})" '正規表現パターン
　　.Global = True
　　For Each c In Range("B1", Cells(Rows.Count, 2).End(xlUp))
　　　Set Matches = .Execute(c.Text)　'←c.Valueの方が少し速いかも……

　　　'*変更開始
　　　If Matches.Count = 1 Then
　　　　buf = buf & "," & Matches(0).SubMatches(0)
　　　ElseIf Matches.Count > 1 Then
　　　　For i = 0 To Matches.Count - 1
　　　　　If i = 0 Then
　　　　　　buf = buf & "," & Matches(i).SubMatches(0)
　　　　　Else
　　　　　　buf = buf & vbLf & Matches(i).SubMatches(0) '二つある場合
　　　　　End If
　　　　Next i
　　　Else
　　　　buf = buf & ","
　　　End If
　　　'*変更終わり

　　　Set Matches = Nothing
　　Next c
　End With
　'排出
　If Len(buf) > 1 Then
　　ar = Split(Mid(buf, 2), ",")
　　Application.ScreenUpdating = False
　　For i = 0 To UBound(ar)
　　　Range("E1").Offset(i).Value = ar(i) '書き出しの場所
　　Next i
　　Application.ScreenUpdating = True
　End If
End Sub

'//

お礼

質問がちゃんと条件を書いてなくて大変失礼しました。
今回のは希望通りの結果となりました。
本来の対象データには「複数ある場合」はないはずなのですが、おかげさまで誤って入力された場合のチェックもできます。
まだ回答のコードを理解できないでおりますが、ありがとうございました。

回答No.4

WindFaller

こんばんは。

1行にいくつあっても可能です。
パターンは、( )の中を書き換えれば、他の文字でも対応可能です。
"([GB]\d{4})"　は、[GB]は、GかB のどれか1つ。\dは、数字の意味。{4}は、前のいずれかの数字を4個
ただし、半角に限ります。

'//
'標準モジュールがベター
Sub Test1()
　Dim objRe As Object
　Dim Matches As Object
　Dim m As Object
　Dim c As Range
　Dim buf As String
　Dim i As Long
　Dim ar As Variant

　With CreateObject("VBScript.RegExp")
　　.Pattern = "([GB]\d{4})"　'正規表現パターン
　　.Global = True
　　For Each c In Range("B1", Cells(Rows.Count, 2).End(xlUp))
　　　Set Matches = .Execute(c.Text)
　　　If Matches.Count > 0 Then
　　　　For Each m In Matches
　　　　　buf = buf & "," & m.SubMatches(0)
　　　　Next m
　　　End If
　　　Set Matches = Nothing
　　Next c
　End With
　'排出
　If Len(buf) > 1 Then
　　ar = Split(Mid(buf, 2), ",")
　　For i = 0 To UBound(ar)
　　　Range("E1").Offset(i).Value = ar(i) '書き出しの場所
　　Next i
　End If
End Sub
'//

お礼

ありがとうございます。
正規表現とは初めて聞く言葉ですが、できました。
ただし、空白セルや該当なしのセルが飛ばされてしまうようで、元データと行があわなくなります。

回答No.3

Chiquilin

そんなに大量のデータでやることもないでしょうから

=IFERROR(MID(B1,LOOKUP(100,FIND(TEXT(MID(B1,ROW($1:$99),4),"!B0000;;;-"),B1)),5),"")
&IFERROR(MID(B1,LOOKUP(100,FIND(TEXT(MID(B1,ROW($1:$99),4),"!G0000;;;-"),B1)),5),"")

とか。

お礼

ありがとうございます。
関数でできるんですね。
ただ、データが大量（1万行くらい）なんです。

回答No.2

MackyNo1

文字列を検索して抜き出すなどの高度な検索置換を行うには、Wordの置換機能を利用されることをお勧めします。

今回の課題なら、エクセルのデータ範囲をコピーして、Wordで「形式を選択して貼り付けで「テキスト」で貼り付けます」（または貼り付けオプションで「テキストのみ」を選択）。
次にCtrl+Hで置換ダイアログを出して、「オプション」ボタンから「ワイルドカードを使用する」にチェックを入れ、検索する文字列に「*([BG][0-9][0-9][0-9][0-9])*^13」置換後の文字列に「\1^13」と入力し「すべて置換」します（\は半角の￥です）。

このようにしてBまたはGの後に4つの数字が続く部分だけが抽出されたデータをエクセルにコピー貼り付けすれば完成です。

お礼

ありがとうございます。
ワードを使うとこんなことができるのですね。
ただ、空白セルが消滅してしまうようなので実際に使えませんでした。

回答No.1

tom04

こんばんは！

手っ取り早くVBAでの一例です。
C列にデータを表示させるとします。
シートモジュールです。
↓のコードをコピー＆ペーストしてマクロを実行してみてください。

Sub Sample1()
Dim i As Long, k As Long
For i = 1 To Cells(Rows.Count, "B").End(xlUp).Row
For k = 1 To Len(Cells(i, "B"))
If Mid(StrConv(Cells(i, "B"), vbNarrow), k, 1) Like "[B G]" Then
If IsNumeric(Mid(Cells(i, "B"), k + 1, 4)) Then
Cells(i, "C") = Mid(Cells(i, "B"), k, 5)
End If
End If
Next k
Next i
End Sub

※　1セルに該当データは複数存在しないという前提です。m(_ _)m

お礼

さっそくありがとうございます。
うまくできたのですが、BやG以外にスペース+数字4桁まで抽出されてしまいました。

補足

Like "[B G]" Then　でBとGのあいだにスペースがあるのでスペース+数字4桁まで抽出されるのかと思い、ためしに Like "*[BG]" Thenとしたところうまくいきました。
Like "*[B,G]" Thenでも良いようです。
これであってますでしょうか？（理屈がよく分からず、すみません。）