VBAでWEB上のデータを変数に代入するには？

VBAで仕事上のデータを処理するシステムを作成しており、
どうしてもWEB上のデータを変数に入れたいのですが、どのような方法が良いでしょうか？

取得したいデータは関税協会にある為替相場です。
http://www.kanzei.or.jp/check/rate_all/2012/2012 …
上記のページに行くとアメリカ合衆国の為替レートが81.33というのがわかります。

VBA上の変数に81.33という数値を入れる方法を教えてください。
よろしくお願いします。

No.5 ベストアンサー 回答者： NOBNNN 回答日時： 2012/03/20 15:16

#2,#4　です。

　いかにUPしましたのでダウンロード願います。　　（２）のほうが処理速度は速いです。

　（１）　＃２（Excel：クエリでWebデータを取り込む）のソース

　　　　https://box.yahoo.co.jp/guest/viewer?sid=box-l-5 …

　（２）　＃4（ブラウザでサイトを開くことなく、プログラムからHTMLソースを取得する方法）
EXCEL にボタンをつけてありますから・・・・　別にExcelでなくても使用できます。

　　　　https://box.yahoo.co.jp/guest/viewer?sid=box-l-5 …


+++++++++++++++++++++++++++++++++++++++++++++++++++++++

>>おそらく私が使い方を理解していないからだと思います

失礼ながら、ボタンを作成してマクロを動かすのもできない
　というレベルだと　このソースの中身の解析や
　質問者さまが実現したい毎日かわるＵＲＬ（為替のレート）
　に対応するためのコードの作成は困難だと思います。

　基礎的な技術を身につけて再度チャレンジしてみてください。

この回答への補足

ご丁寧にサンプルまで作っていただけて感激です。
ありがとうございます。

それと、私の返答の文章がおかしかったです、申し訳ありません。

ボタンを作成してマクロが作れないという意味ではなく、
ユーザーフォームにボタンを設置した場合に頂いたコードを貼り付けようとしたのですが、
うまく動かないので再度教えてくださいという意味でした。

↓こんな感じにしたかったのです。
http://appstrading.com/gazou.JPG

どちらにせよ勉強不足ではありますが、お時間があるときで結構ですので
ユーザーフォームへの設置の仕方を教えていただけませんでしょうか？
何度もお願いをして大変恐縮ではありますが、よろしくお願いします。

補足日時：2012/03/23 23:14

この回答へのお礼

問題は自己解決できました。
多くのサンプルまで頂けて本当にわかりやすかったです。
本当にありがとうございました。

お礼日時：2012/03/24 21:09

No.4 回答者： NOBNNN 回答日時： 2012/03/19 02:28

#2　です。

＃２ よりも効率的なやり方が見つかりましたので実験ソースを公開します。
下記のサイトを参考にしました。＜！感謝＞

　◆ブラウザでサイトを開くことなく、プログラムからHTMLソースを取得する方法です。
　 　http://www.kanaya440.com/contents/tips/vbs/007.h …

このソースで実験してみたところ　＃２にくらべて　かなり高速です。
Ｅｘｃｅｌ でなくても使えます。

#3の方もいっているとおり、あとは　ＵＲＬ　のアドレスをどうするのかが問題ですけど。

++++++++++++++++++++++<サンプル　実験ソース >+++++++++++++++++++
Option Explicit

Const cns_URL As String = "http://www.kanzei.or.jp/check/rate_all/2012/2012 …

Const FindString As String = "アメリカ合衆国", FindMoney As String = "ドル(USD)"

Private m_strHTML As String

Private m_FindOK As Boolean

Private m_Anser As String

Sub DollerYen_GET_PROC()

Dim arryHTML As Variant

Dim row As Integer
Dim I As Integer
Dim strWk As String

m_FindOK = False
m_Anser = Empty

If GetHtmlSource(cns_URL, m_strHTML, False) = False Then
GoTo MSG_DollerYen_GET_PROC
End If



arryHTML = Split(m_strHTML, vbLf)

For row = 0 To UBound(arryHTML)

'Debug.Print (arryHTML(row))

If InStr(1, arryHTML(row), FindString) > 0 Then
If InStr(1, arryHTML(row + 2), FindMoney) > 0 Then
m_FindOK = True
strWk = ""

For I = 1 To Len(arryHTML(row + 4))

strWk = Mid(arryHTML(row + 4), I, 1)

If IsNumeric(strWk) Or strWk = "." Then
m_Anser = m_Anser & strWk
End If
Next I
Exit For
End If
End If
Next row

MSG_DollerYen_GET_PROC:
If m_FindOK Then
MsgBox "アメリカ合衆国 ドル(USD) は（" & m_Anser & "円)です。"
Else
MsgBox "為替（アメリカ合衆国）の値が見つかりません。", vbExclamation
End If
Exit_DollerYen_GET_PROC:
Exit Sub
End Sub
'####################################################################################
'#
'# 関数名：GetHtmlSource
'#-----------------------------------------------------------------------------------
'# 機能 ：指定のURLからHTMLソースを取得する
'# 引数 ：strURL I URL
'# strRetVal O 取得した文字列
'# isSJIS I ソースが Shift-JIS の場合 True
'# strID I ドメイン認証が必要な場合のユーザーID
'# strPass I ドメイン認証が必要な場合のパスワード
'# 戻り値：True 正常、False 失敗
'#
'####################################################################################
Private Function GetHtmlSource(ByVal strURL As String, _
ByRef strRetVal As String, _
Optional ByVal isSJIS As Boolean, _
Optional ByVal strID As String, _
Optional ByVal strPass As String) As Boolean

Dim oHttp As Object

'オブジェクト変数に参照をセットします
On Error Resume Next
Set oHttp = CreateObject("MSXML2.XMLHTTP")
If (Err.Number <> 0) Then
Set oHttp = CreateObject("MSXML.XMLHTTPRequest")
End If
On Error GoTo 0
If oHttp Is Nothing Then
MsgBox "XMLHTTP オブジェクトを作成できませんでした。", vbCritical
Exit Function
End If

'ドメイン認証が必要な場合
If strID <> "" Then
oHttp.Open "GET", strURL, False, strID, strPass
Else
oHttp.Open "GET", strURL, False
End If
oHttp.Send

'失敗した場合は関数を終了します。
If (oHttp.Status < 200 Or oHttp.Status >= 300) Then Exit Function

'ソースを格納します
If isSJIS Then
'ソースが Shift-JIS の場合
strRetVal = StrConv(oHttp.responseBody, vbUnicode)
Else
'ソースが Unicode の場合
strRetVal = oHttp.responseText
End If

'オブジェクト変数の参照を解放します
Set oHttp = Nothing

'戻り値をセットします
GetHtmlSource = True

End Function

+++++++++++++++++++++++++++++++++++++++++++++

参考URL：http://www.kanaya440.com/contents/tips/vbs/007.h …

この回答への補足

NOBNNN様
色々調べてくださったようで詳細なご回答に感謝します。

是非実行したかったのですが、まだVBAの勉強をしたばかりでして
せっかく頂いたコードを活用できずにいます、、

ボタンを設置して、それを押したらドル円の値を変数に入れる形にしたかったので
ボタンを設置し、上記のコードを貼り付けましたが、プロシージャー内では無効というエラーがでてしまいます。

おそらく私が使い方を理解していないからだと思います。
もうちょっと勉強してみますが、もし追加で実行に移せるアドバイスを頂けたら嬉しいです。

お手数をおかけして申し訳ありませんが、もしお時間ありましたらお願いします。

補足日時：2012/03/20 09:44

No.3 回答者： ki-aaa 回答日時： 2012/03/18 23:50

こんにちわ

81.33という数字は、今日(2012/3/18)現在のものです。
アドレス xxx.kanzei.or.jp/check/rate_all/2012/20120318.htm

日が経てばまた違った値になります。
アドレスも作り直す必要かあります。

アドレスさえ作れば、数値を持ってくるのはそんなに難しいことではないです。
なので、アドレスがどういうルールで作られているか、
またはどういう方法で入力されているかを教えてください。

No.2 回答者： NOBNNN 回答日時： 2012/03/18 22:40

先に#1　の方も答えていますが　ＥＸＣＥＬで実験してみました。

とりあえず　下記ソースをモジュールとして貼り付け、マクロを実行してみてください。

やり方は
(1) http://kabu-macro.com/kouza/kabuka_shutoku/kueri …
(2) http://kabu-macro.com/kouza/kabuka_shutoku/macro …
(3) http://www.d3.dion.ne.jp/~jkondou/excelvba/T2.htm

を参考にしています。

ただ性能的には遅く、ＶＢ.ＮＥＴ2008 などで　ご自分で別なDLL　として作成したほうがいいかも
外部クラス参照でＶＢＡからできるようにすれば可能です。


++++++++++++++++++<サンプルソース> +++++++++++++++++++


Option Explicit

Const cns_WkSheet = "_ExchengeSheet"

Sub USD_Yen_GET()

Dim FindFlg As Boolean: FindFlg = False

Dim strAnser As String: strAnser = Empty

Dim MyRange As Range

Dim NowSheet As String

NowSheet = ActiveSheet.Name

With Worksheets.Add()
.Name = cns_WkSheet
End With


With ThisWorkbook.Worksheets(cns_WkSheet)
.Activate
End With

Call Exchenge_WEB_GET

Set MyRange = Columns("A:B").Find(What:="アメリカ合衆国") '"アメリカ合衆国"の文字列を探す

If Not (MyRange Is Nothing) Then '見つかったか？
If MyRange.Offset(0, 1) = "ドル(USD)" Then 'レートの文字 "ドル(USD)"があるか？
strAnser = MyRange.Offset(0, 2)
FindFlg = True
End If
End If

With ThisWorkbook.Worksheets(cns_WkSheet)
Application.DisplayAlerts = False
.Delete
Application.DisplayAlerts = True
End With

ThisWorkbook.Worksheets(NowSheet).Select

If FindFlg Then
MsgBox "アメリカ合衆国 ドル(USD) は（" & strAnser & "円)です。"
Else
MsgBox "為替（アメリカ合衆国）の値が見つかりません。", vbExclamation
End If
End Sub


Private Sub Exchenge_WEB_GET()
'
' Macro1 Macro
' マクロ記録日 : 2012/3/18
'
' 外部データの取得 Webクエリ
'
' ActiveWorkbook.Worksheets.Add
With ThisWorkbook.Worksheets(cns_WkSheet).QueryTables.Add(Connection:= _
"URL;http://www.kanzei.or.jp/check/rate_all/2012/2012 … Destination:= _
Range("A1"))
.Name = "20120318"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlEntirePage
.WebFormatting = xlWebFormattingNone
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With
End Sub
+++++++++++++++++++++++++++++++

No.1 回答者： notnot 回答日時： 2012/03/18 21:57

ExcelのVBAであれば、このあたりで調べてください。

http://www.google.co.jp/search?q=excel+web%E3%82 …

Excel以外だとちょっと大変だと思います。