セル内の文字から金額のみを抜き出して、別のセルに表示させたい

セル内の文字から金額のみを抜き出して、別のセルに表示させたいと思っています。
以下の条件の時に旨く抽出できないのでご教授ください。

[条件]
・セル内の文字列には他の数字が前後に含まれることがあります。
・文字列は定型の内容ではありません。
・一つの文字列に入力される金額は必ずひとつだけです。
・金額には必ず「円」が付きます。
・金額の桁数は一定ではありません。


[実現したい事]
以下のようにA列に入力されている文字列の中から、金額のみを抽出してB列に表示させたい
※実際のセル内の文章は定型のモノではありません。

A1：30分の金額は1,000円（いつでも）
A2：10分の金額は500円（2人で10分）
A3：1時間の金額は9,500円（30分で1回休憩）

B1：1,000
B2：500
A3：9,500

No.3 回答者： WindFaller 回答日時： 2015/12/02 20:50

こんばんは。

>10分の金額は500円（2人で10分）
金額は、2番目の位置にありますが、この順番が替わるようですと、ワークシート関数では無理ではないかと思います。
#1さんとは別のスタイルで、#2さんの「負がなく小数点や桁区切り含め」をいただき、回答とさせていただきました。以下のように正規表現を使いますと、いろいろな対応が可能になります。
百千万億兆　などか入ったものは、以下の正規表現パターンを替えなくてはなりません。
　"(([△\-+]?[\d,]+[百千万億兆]*)+)円" 'アラビア数字と漢数字混じりの時


'//
Sub PickNumbers()
Dim c
If TypeName(Selection) = "Range" Then
　For Each c In Range("A1", Cells(Rows.Count, "A").End(xlUp))
　　c.Offset(, 1).Value = WhichNumYen(c)　'右隣のセルに記述　c.Offset(,1)の1が右隣セル1個 B列に出力
　Next c
End If
End Sub
Function WhichNumYen(ByVal rng As Variant)
　Dim Matches
　Dim n As String
　Dim m As Variant
　Dim buf As String
　If TypeName(rng) = "Range" Then
　　n = rng.Value
　Else
　　n = rng
　End If
　n = StrConv(n, vbNarrow)
　With CreateObject("VBScript.RegExp")
　　.Pattern = "([△\-+]?[\d,\.]+)円"　'正規表現パターン
　　.Global = True
　　.IgnoreCase = False
　　
　　Set Matches = .Execute(n)
　　If Matches.Count > 0 Then
　　　For Each m In Matches
　　　　buf = buf & "＋" & m.SubMatches(0)
　　　Next m
　　End If
　End With
　WhichNumYen = Mid(buf, 2)
End Function
'///

No.2 回答者： CoalTar 回答日時： 2015/12/01 17:02

負がなく小数点や桁区切り含め9文字以内(変更可)で

=-LOOKUP(1,-RIGHT(LEFT(A1,FIND("円",A1)-1),{1,2,3,4,5,6,7,8,9}))

No.1 回答者： tom04 回答日時： 2015/11/30 22:55

こんばんは！

数日前にも似たような質問がありました。

関数でやると結構厄介だと思いますので、
この質問専用の関数（ユーザー定義関数）を作ってみてはどうでしょうか？
「円」から数値もしくはカンマが連続する間遡って検索するようにしています。

Alt＋F11キー　→　メニュー　→　挿入　→　標準モジュール　→　VBE画面のカーソルが点滅しているところに
↓のコードをコピー＆ペーストします。

Function kingaku(myRng As Range) 'この行から//
Dim k As Long, myEnd As Long
Dim str As String
myEnd = InStrRev(myRng, "円")
k = myEnd
Do
k = k - 1
str = Mid(StrConv(myRng, vbNarrow), k, 1)
If Not str Like "[0-9,]" Then Exit Do
Loop
kingaku = Mid(myRng, k + 1, myEnd - k - 1) * 1
End Function 'この行まで//

Excel画面に戻り（VBE画面を閉じて）通常の関数のような使い方をします。

B1セルに
=kingaku(A1)
という数式を入れフィルハンドルで下へコピー！
（セルの表示形式は桁区切りスタイルもしくはユーザー定義で調整してください）

※　エラー処理は行っていませんので、IF関数などと併用しエラー処理を行います。

=IFERROR(kingaku(A1),"")
こんな感じでしょうかね。

尚、保存時は「マクロ有効ブック」として保存します。m(_ _)m