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

質問

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

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

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

回答No.5

NOBNNN · ベストアンサー

#2,#4　です。

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

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

　　　　https://box.yahoo.co.jp/guest/viewer?sid=box-l-5gyoz3775q364cwhmx2zwfjr5m-1001&uniqid=b95a35f3-307b-4636-9fa2-20caeb6851a9&viewtype=detail

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

　　　　https://box.yahoo.co.jp/guest/viewer?sid=box-l-5gyoz3775q364cwhmx2zwfjr5m-1001&uniqid=3ada2b33-5481-467e-9f00-e3735b25ee1f&viewtype=detail

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

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

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

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

お礼

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

補足

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

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

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

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

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

回答No.4

NOBNNN

#2　です。

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

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

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

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

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

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

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.html

補足

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

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

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

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

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

回答No.3

ki-aaa

こんにちわ

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

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

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

回答No.2

NOBNNN

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

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

やり方は
(1) http://kabu-macro.com/kouza/kabuka_shutoku/kueri.html
(2) http://kabu-macro.com/kouza/kabuka_shutoku/macro_kabuka.html
(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/20120318.htm", 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

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

http://www.google.co.jp/search?q=excel+web%E3%82%AF%E3%82%A8%E3%83%AA+vba

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