![](http://oshiete.xgoo.jp/images/v2/pc/qa/question_title.png?5a7ff87)
エクセルでこんなことができますか?
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ベストアンサー
- 回答日時:
#7-9です。
> すみませんが、このご回答への補足ではありません。
> 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と比べて)"もっと早くなりました。"という結果の違いも
実はセル参照の数の違いが原因であって、構文の問題ではないですね。
試しに以上説明のように変数の扱いだけ書き換えてみましたが、
こちらのダミーデータでは、#9補足欄のマクロをさらに4割ほど時短できました。
もし興味あるようでしたら、InStr版の方も第一引数に文字列型変数を指定するように書ければ、
セルの文字列値を全桁ループするよりは1~2割速くなる筈です。
その他の記述については、かなりのレベルで書けていると思います。
Like 演算子(というよりパターンマッチング全般)は、比較的処理が遅いので、
Like "*[BG]####*"の代りにIsNumeric()とLen()を組み合わせて、
同等の仕様を実現するのも(試してませんが)有望と思いますが、
記述を複雑にするよりは、Like 演算子の「シンプルに書ける」特長を活かした方が
いいのかも知れませんね。
以下、#9補足欄のマクロについて変数の扱いだけ書き換えたものです。
' ' ==================================================
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
' ' ==================================================
蛇足ですが、#9の配列変数版についてです。
(特に明言されていませんが多分)
1つにセルに付き1つの対象文字列を取り出せば十分、
という条件のようなので、それに合わせて
ほぼ#9補足欄のマクロ同等の仕様で書き直しておきます。
今すぐは解らなくても構いませんし、見送って貰っていいと思いますが、
速さの為の方法として配列変数は結構有力なので、
いつか何かの参考になればと思っています。
(NMin()関数は#9のままです)
' ' ==========配列変数版==============================
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) ' 出力用二次元配列を元データの行数*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"に続く4桁が数字文字列ならば
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
- 回答日時:
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
- 回答日時:
#7-8です。
もう一例挙げておきます。
配列変数を使って、読み易さや解り易さや字数の少なさよりも処理速度を優先した書き方です。
私個人は最も得意とする慣れた書き方ですが、質問掲示板ではあまり受けがよくないんですよね。
条件(サンプルの作り方)によっては、一万件程度でも、
正規表現で一括置換するよりも、処理が速い場合もあります。
外部オブジェクトを使うよりは配列変数の方が技術的に難しく感じないのかなぁ、と思いました。
技術的な補足として、
★の部分の判別の仕方と関数の内容は、Sub Re8819211a改()に応用すれば4割位時短になります。
数多くなり過ぎて大変になっちゃったらスミマセン。
私の意図としては、これも挙げておいた方が、そちらで選ぶ基準が持ち易いのでは?と。
今から数日、また返信出来ませんが、それでも補足あれば必ずチェックしますので。
' ' ==========配列変数版==============================
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)を仮に5で指定
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"に続く4桁が数字文字列ならば★
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
' ' /// 2つの非負整数の内 最少の自然数(0以外の最少数)を返す。
' ' /// 2つの非負整数の両方が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
- 回答日時:
#7、cjです。
全体を読み返して気が付いたことがあるので、追加自己レスです。
マクロは2例とも差し替えになります。
> マッチした位置情報に意味は ...
質問文からは読み取れませんでしたが、
元データと同じ行位置に結果を出力したい、ということのようなので、
書き直しました。
事前に想定はしていませんでしたが、少しの修正で済みました。
' ' ==========簡易簡潔版==============================
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"から始まり数字が4桁続く文字列ならば
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
' ' /// 2つの引数の内 最少の自然数(0以外の最少数)を返す。
' ' /// 2つの引数の両方が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
' ' ==================================================
比較的処理が速い方の版については、記述内容としては寧ろ簡素になります。
ただ、
ひとつのセルに複数マッチした場合に、
単純にそれらを(区切り文字なしで)連結したものを出力するのが基本仕様です。
なので、複数列に分けて出力できるように、オマケを10行書き足しました。
ひとつのセルに複数マッチすることは無い、と担保されていた場合でも、
オマケの記述以外は全く同じものになりますから、余計なコストは掛かっていません。
逆に複数マッチしても最初にマッチしたものだけを返すなんて条件も想像できますが、
少しの工夫で済みますし、後から処理するのでも難しくないですから、ここには書きません。
重複の削除については、元データと同じ行位置に結果を出力するならば不要でしょうし、
今回の書換えによって、ついでに処理するようには書けないので、ここには書きません。
' ' ==========一連文字列・正規表現・貼り付け版 =======
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
' ' ---------- 結果を複数列に出力する場合は以下10行イキ --------
'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
' ' ==================================================
尚、何れのマクロも、出力先の先頭をK1に指定してあります。
"K" の行の記述を運用に合わせて指定し直してください。
何かあれば補足欄に書いてみてください。
それでは。。。
この回答への補足
よく見直したら
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
でいけますよね?
理解不足ですみません。
何度もありがとうございます。
今回は、ご解説いただいた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
とやってみることにしました。すみません。
また教えていた大方法は、じっくり勉強させていただいて身につけたいと思っております。
ありがとうございました。
No.7
- 回答日時:
こんにちは。
お邪魔します。また、回答(質問を閲覧することも)お休み中なのですが、
お気に入りのアバターをまたまた偶然見つけたので、参加してみます。
題意の細かい部分は確認してみないといけない点も幾つかありますが、
パッと見、の解釈で、2通り挙げてみます。
違っている点があればご指摘下さい。
マッチした位置情報に意味は無い前提ですが、
見つかる順番には意味があるのかも?ですね。
セルの中に複数マッチする場合も処理するように書いておいた方が
殆どコストも掛からないのでベターだと私も思います。
("抜き出す"場合、こういうのは慣習というか慣例というか、、、。)
一万行程度なら1秒以内で済みますが、処理が速いやり方ではありません。
' ' ==========簡易簡潔版==============================
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"から始まり数字が4桁続く文字列ならば
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
' ' /// 2つの引数の内 最少の自然数(0以外の最少数)を返す。
' ' /// 2つの引数の両方が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
' ' ---------- 重複を除く場合は以下8行イキ ------
'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
' ' ==================================================
直接の返事が無いようなので、#1補足の問題について軽く触れてみます。
Like 演算子のパターンに用いるキャラクターセットの記法ですが、
(要するに "[" と "]" の間の書き方)
[BG}
のように間に何も挟まない(区切らない)のが正解です。
[B G] や [B,G]
は間違いで、それぞれ、半角スペースやカンマを拾ってしまいます。
#最近ベテラン回答者さんがうっかり書き間違えたのが広まってしまって(?)
#半角スペースやカンマを挟むのが流行っているようですが、間違いは間違いです。
詳しいことは、Like 演算子のVBAヘルプで確認してください。
覚える必要がある約物は、? * # [ ] ! だけでいいです、
以上です。
cj_mover さん、いつもご丁寧にお教えいただきありがとうございます。
>マッチした位置情報に意味は無い前提ですから、
大変申し訳ありません。
わたしが、前提となる条件をきちんと書いておかなかったためお手間をとらせてしまいました。
どのセルにあるかも必要だったのです。
Like演算子の解説もとても勉強にになりました。
今回はとても急いでおり、すでにNo1,6の方のご回答をもとに実装のテストを行っております。
すみませんでした。
No.6
- 回答日時:
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
- 回答日時:
#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
- 回答日時:
こんばんは。
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
- 回答日時:
そんなに大量のデータでやることもないでしょうから
=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),"")
とか。
No.2
- 回答日時:
文字列を検索して抜き出すなどの高度な検索置換を行うには、Wordの置換機能を利用されることをお勧めします。
今回の課題なら、エクセルのデータ範囲をコピーして、Wordで「形式を選択して貼り付けで「テキスト」で貼り付けます」(または貼り付けオプションで「テキストのみ」を選択)。
次にCtrl+Hで置換ダイアログを出して、「オプション」ボタンから「ワイルドカードを使用する」にチェックを入れ、検索する文字列に「*([BG][0-9][0-9][0-9][0-9])*^13」置換後の文字列に「\1^13」と入力し「すべて置換」します(\は半角の¥です)。
このようにしてBまたはGの後に4つの数字が続く部分だけが抽出されたデータをエクセルにコピー貼り付けすれば完成です。
ありがとうございます。
ワードを使うとこんなことができるのですね。
ただ、空白セルが消滅してしまうようなので実際に使えませんでした。
お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!
似たような質問が見つかりました
- Excel(エクセル) エクセルで日付が入っているセルを一定の法則に従って違うセルに表示したい 2 2022/04/04 17:16
- Excel(エクセル) 関数EXACT(文字列,文字列)とexcelVBA 3 2022/04/14 15:07
- Excel(エクセル) エクセルの関数式を教えてください。 2 2022/11/29 21:09
- Excel(エクセル) エクセルの書式設定の表示形式で設定した文字を文字列としてコピーしたい 1 2022/12/21 10:41
- Excel(エクセル) 【再度】Excelの関数について教えてください。 4 2023/07/28 13:06
- Excel(エクセル) エクセルで、 A1セルに「A」という値、 B1セルに「B」という値が入っています。 どちらも表示形式 5 2023/02/22 23:05
- Visual Basic(VBA) Excel VBA 最終行を取得しVlookup関数をコピーする方法をコーディングで教えてください。 3 2023/05/11 13:14
- Visual Basic(VBA) vbaエクセルマクロ RemoveDuplicatesについて RemoveDuplicatesを使 3 2023/02/28 01:13
- Excel(エクセル) エクセル表作成について 5 2023/03/12 13:25
- Excel(エクセル) WORKDAY関数 4 2023/06/08 13:23
関連するカテゴリからQ&Aを探す
デイリーランキングこのカテゴリの人気デイリーQ&Aランキング
-
絶対参照
-
SUMIF関数で、「ブランク以外を...
-
自分の左隣のセル
-
エクセル1行おきのセルを隣の...
-
エクセルVBAでチェックボックス...
-
エラー「#REF」の箇所を置き換...
-
【Excel】4つとばしで合計する方法
-
セルを結合した時のエクセル集...
-
エクセルで、指定の値よりも大...
-
エクセル 列のアルファベット...
-
指定セルクリックでカレンダー表示
-
スプレッドシートの作業範囲
-
何時から何時までを○○、何時か...
-
エクセルで出勤シフト表中の数...
-
エクセル関数/任意の桁数の数...
-
エクセル2010で規則性のある文...
-
EXCEL-同じ組み合わせになった回数
-
INDEX関数とMATCH関数(長...
-
EXCELの関数
-
エクセル、○が連続する回数を数...
マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング
-
SUMIF関数で、「ブランク以外を...
-
文字列から英数字のみを抽出す...
-
エクセル1行おきのセルを隣の...
-
自分の左隣のセル
-
エクセルで、指定の値よりも大...
-
excelで、空白を除いてデータを...
-
セルを結合した時のエクセル集...
-
EXCELでマイナス値の入ったセル...
-
エクセルで、A2のセルにA3...
-
エクセルで特定のセル内にだけ...
-
EXCELのcountif関数での大文字...
-
エクセルに入力後、別シートの...
-
同一セル内の重複文字を削除し...
-
【Excel】4つとばしで合計する方法
-
条件付き書式の色付きセルのカ...
-
【Excel】IF文「ある文字を含ん...
-
エクセルでエンターを押すと任...
-
エクセルで年月日から月日のみへ
-
エラー「#REF」の箇所を置き換...
-
Excelで大量のセルに一気に関数...
おすすめ情報