VBAにて文字列の数字を抽出（スペース含まれる）

質問

例（B3セル）
○○商店　1号店　京都　2001/3/24　価格　'07～'08

　の「2001/3/24」部分をC3に抽出

*文字列にはスペースを含み、B3からデータのある所（約300行）までの結果をC列に抽出したいと思います。
　セル内の並び順はまちまちです。

参考にできるWebなどありましたら宜しくお願い致します。

回答No.5

noname#187541 · ベストアンサー

No.1・3です。

例としてあげている文字列を日付の位置を変えて複数で試してますが、きちんと抽出されます。

含まれるスペースは、例では全角なので全角で処理していますが、実際は半角であるとか、日付部分の前後にはスペースがないとか、実際のデータと例には、何か違いがありませんか？

お礼

再度　回答有難う御座います。

スペース部分ですが、全角に見える所が「半角」X2となっておりました。
＞mystr = Split(myrng.Value, "　")
「" "」とし結果OKでした。

お手数お掛けしました。
VBAとてもすっきり気に入っております。

回答No.4

Wendy02

こんばんは。

>○○商店　1号店　京都　2001/3/24　価格　'07～'08

スペースがなくても、どこにあっても構いませんが、年月日はひとつのセルに二つあれば、最初側のものを取得します。
なお、以下のマクロは、年数が3桁の場合は、例えば、201 は、01を取得して、それを年数に変えますから、2001年として扱われます。しかし、年は、4桁のほうが確実です。今のコードでは、2桁は間違った年月日が出る可能性があります。

ユーザー定義関数の前のPrivate キーワードを外して、ワークシートに数式を貼り付ければ、そのまま年月日を取り出すことが可能です。正規表現さえ書ければ、他に取り出すことも可能です。

'-------------------------------------------

Sub MacrpTest1()
'実行マクロ
Dim c As Range
Dim buf As Variant
　Application.ScreenUpdating = False
　With ActiveSheet
　'指定範囲
　For Each c In .Range("B1:B300")
　　If VarType(c) = vbString Then
　　　 buf = PickUp(c.Value)
　　　 If IsDate(buf) Then
　　　　c.Offset(, 1).Value = CDate(buf)
　　　 End If
　　End If
　Next c
　End With
　Application.ScreenUpdating = True
End Sub

Private Function PickUp(strTxt As Variant, Optional Ptn As String = "")
Dim buf As String
Dim Matches As Object
With CreateObject("VBScript.RegExp")
　 strTxt = Trim(StrConv(strTxt, vbNarrow))
　 If Ptn = "" Then
　　 .Pattern = "(\d{2}|\d{4})\/\d{1,2}\/\d{1,2}"
　 Else
　　 .Pattern = Ptn
　 End If
　.Global = False
　If .Test(strTxt) Then
　　Set Matches = .Execute(strTxt)
　　buf = Matches(0).Value
　Else
　　buf = ""
　End If
End With
　 PickUp = buf
End Function

お礼

回答有難う御座います。
月数字が「03」の時でも、結果は「3」と表示されますのでとても感動しております。

＞年は、4桁のほうが確実です。
元データは常に4桁ですのでよかったです。ご親切に有難う御座います。

ワークシートに貼り付けるとした場合「どこ」から「どこまで」か詳細教えて頂けますと有難いです。素人で申し訳御座いません。

回答No.3

noname#187541

No.1です。

＞セル内の並び順はまちまちです。
これを見逃してました。それとB列（連続での入力として）対応にしました。

Dim mystr() As String
Dim i As Long
Dim tmp As String
Dim myrng
For Each myrng In Range("B3:B" & Range("B" & Rows.Count).End(xlUp).Row)
mystr = Split(myrng.Value, "　")
For i = 0 To UBound(mystr)
If IsDate(mystr(i)) Then tmp = mystr(i)
Next
myrng.Offset(, 1).Value = tmp
Next

参考にどうぞ。

お礼

2度の回答有難う御座います。
VBA実行後、何も変化なしとなってしまいました。
一度確かめて頂けますと助かります。

回答No.2

tom04

こんばんは！
お役に立てるかどうか分かりませんが・・・

VBA以外で無理矢理って感じの方法になってしまいますけど

「価格」の前に「月日」が「2009/7/26」のように入力されている場合限定ですが、

C3セルを
=IF(B3="","",MID(B3,FIND("200",B3)-1,11))
としてオートフィルで下へコピーではダメでしょうか？

尚10月以降2桁の月もあるためこのような数式にしましたが、

万一、1桁（～9月）までの月の場合は
年月日の次にスペースがない場合はスペースの次の文字も拾い出してしまいます。

そして、月日が2010年以降とか1999年だとエラーになります。
また、年月日以外に「200」という数値があれば
希望通りの表示になるかどうか分かりません。

以上、参考にならなかったら無視してくださいね。m(__)m

お礼

有難う御座います。
質問事項に添わないのですみません。

回答No.1

noname#187541

こんばんは。

文字列の内容がすべて同じ規則、つまり、スペースで区切られていて抜き出す日付が4番目にあるのであれば、Split関数で出来ます。

Dim mystr() As String
mystr = Split(Range("B3").Value, "　")
Range("C3").Value = mystr(3)

Split関数の第2引数は区切り文字の指定ですが、提示の文字列のスペースが全角のスペースなので、全角スペースにしています。