【VBA】RSSをMicrosoft XMLでセルに取り込む

こんにちは、Ryoです。
XMLを利用したサービスのRSSは主にニュースなどの更新情報の配信に利用されています。これを利用して私自身が主要ニュースをサラッと一読できるようにしたかったこともあり、今回はMicrosoft XMLサービスを使用してRSS2.0フィードをセルに定期的に取り込む（自動更新）サンプルを作成してみましたので、その内容について書いていきます。

1.サンプル概要
2.サンプルコード
3.まとめ

1.サンプル概要

RSS配信サイトとしてyahooがありますので、私はVBAでその中の主要ニュースをExcelのSheet1に定期更新して書き込み、時間のある時に読んでいます。更新完了のメッセージボックスは5秒後に自動的に閉じるようにしていますが、いつも使用していたWSHのPopupでは上手く動作しなかったので今回はAPI（MessageBoxTimeoutA）を使用しています。

ちなみにセルA1,A2の表題やリンク先、titleなどの見出しやテーブル設定は事前にワークシートに設定しているものになります。

定期的に更新する作業を自動的に行うようにonTimeメソッドを利用していますので、1時間ごとに繰り返しますがその際に重複データは除き、新しいデータを最終行に追加していく形にしています。

RSSを取り込むだけであればExcelの「開発」タブにある「ソース」から「XMLの対応付け」を行えばできますが、インポートが成功しても「一部のデータはテキストとしてインポートされました」のエラーメッセージが毎回発生して煩わしかったこともありVBAで組んでいます。

2.サンプルコード

◆前提

上にも書きましたが前提としてRSSデータを取り込むシートの事前準備が必要になりますが、ここは任意で良いと思います。

セルA3の部分は更新日付を入力する欄として設定しているので、そこにだけ適当な日付データを入力しておけばデータの取得自体は問題なく実行されます。が、以下のような形になって見難いので、自身の使い勝手に合わせて適宜修正すればOKです。

今回CreateObject関数を利用しているので私の環境では問題なかったこともあり参照設定をしていませんが、XMLサービスを利用する場合に通常はVBエディターの「ツール」⇒「参照設定」から「Microsost XML v3.0」をオンにすることで利用できるようになりますので、ご参考までに。

モジュールとしては2つ使用しており、「Module1」がRSSチェックと更新用で「Module2」がメッセージボックスオートクローズ用になります。またブック開閉時の処理として「Workbookモジュール」にも記述しています。

◆Module1・・・RSSチェック／自動更新

Public onTimer As Date '自動更新用パブリック変数
Dim mXML As Object 'ｍXMLとDtsはモジュールを跨いで使用
Dim Dts As String
'定数として取得したいRSSのURLを記述
'サンプルではyahoo主要News
Const mURL As String = _
"https://news.yahoo.co.jp/rss/topics/top-picks.xml"

Sub RSS_Check()

    '※※本サンプルはyahoo主要News（RSS配信）を取込み、
    '　　新しい内容を順次セルへ追加していくものです※※

    Dim lastTime As Date
    'CreateObject関数でMS XMLのDOM Documentを生成
    Set mXML = CreateObject("MSXML2.DOMDocument")
    '読取り時のエラー対処
    mXML.async = False
    mXML.setProperty "ServerHTTPRequest", True
    '指定したURLのXMLファイルを読み込む
    mXML.Load mURL
    
    'pubDate要素内容から月日と時刻を抜き出して結合
    With mXML.getElementsByTagName("pubDate").item(0)
      D1 = Mid(.Text, 1, 10)
      D2 = Mid(.Text, 12, 8)
      Dts = D1 & " " & D2
    End With
    
    '上で抜き出したデータを日付データに変換
    lastTime = CDate(Dts)
    
    'Sheet上のセルA3に書込まれた日付データと取得したデータを比較し、
    'lastTimeデータが新しい場合に「RSS_UpDate」プロシージャを実行
    If lastTime > CDate(ThisWorkbook.Sheets("Sheet1").Range("A3").Value) _
     Then Call RSS_UpDate
    Set mXML = Nothing  'mXML変数の解放
    onTimer = Now + TimeSerial(1, 0, 0)  '現時刻から1時間後をonTimerに代入
    Application.OnTime onTimer, "RSS_Check"  '上記セット時刻に再度実行
    
End Sub

このコードでデータの取得と更新日付の確認、自動実行用のタイマー設定を行っています。Const mURL As String = ＊＊＊では取得したいRSSのURLを設定する記述部分になります。

流れとしては先ず取得したいRSS配信サイトの設定と読み込み、その中のpubDate要素から日付データを抜取り～変換して更新要否判定を行います。この時にセルA3に記入されている日付データと比較するので、一番最初に起動する際は動作に支障ない範囲の適当な日付データを入力しておきます。

更新「要」と判定した場合、実際に更新作業を行う後述するRSS_UpDate( )を実行させます。

後はパブリック変数として定義したonTimerに現時刻の1時間後をセットして次行のonTimeメソッドで1時間後に再度RSS_Check( )プロシージャを実行させることで1時間ごとの自動更新としています。

ちなみにTimeSerial（時,分,秒）ですので、例えば30分毎にしたい場合はTimeSerial（0，30，0）のようになります。

ここで1点注意ですが、手動で本プロシージャを連続して実行すると、その度にonTimerに現時刻＋タイマー設定時間が代入されて蓄積されていきます。例えば動作を確認する為に連続して1分間隔程度で5回実行したとすると、その1時間後、1時間1分後、1時間2分後・・・のようになりますのでご留意ください。特に問題はないのですが知っておかないと私のように？？？となります。

Sub RSS_UpDate()
    Dim itemElement As Object  'RSS2.0「Item」要素の取得用
    Dim i As Integer, j As Integer
    Dim mObj As Range, mRange As Range
    Dim keyword As String
    Dim R As Long
    Dim ws As Worksheet
        
    'RSS2.0フィードをセルに書込むSheetを設定
    Set ws = ThisWorkbook.Sheets("Sheet1")
    '「Item」要素の取得
    Set itemElement = mXML.getElementsByTagName("item")
    '「pubDate」要素をセルA3に日付形式の文字列で書込む
    ws.Range("A3").Value = Format(CDate(Dts), "yyyy/mm/dd hh:mm:ss")
    '現在アクティブなSheetのデータ書込み開始行を取得
    R = ws.Cells(Rows.Count, "A").End(xlUp).Row + 1
    'title入力列(B列）の重複データ有無検索範囲設定
    Set mRange = ws.Range("B5:B1048576")
    
    'RSS読込データ「Item」要素全てに対しループ処理実施
    'Lengthプロパティにて要素数、「Item」子要素数は
    'ChildNodesプロパティで取得する
    For i = 0 To itemElement.Length - 1
        For j = 0 To itemElement.item(i).ChildNodes.Length - 1
           With itemElement.item(i).ChildNodes.item(j)
           '取得したい要素名"title","link","pubDate","description"に
           '該当する場合、対象のセル列に出力する
            Select Case .nodeName
              Case "title"
                'このサンプルで指定しているURLは最初に"title"から
                '読み込まれるので、重複有無検索と判定を実施
                keyword = .Text
                Set mObj = mRange.Find(keyword, LookAt:=xlWhole)
                If mObj Is Nothing Then
                   ws.Cells(R, 2).Value = .Text
                 Else
                   '重複時は次のItem要素に移りたいので強制移行
                   GoTo jmp:
                End If
              Case "link"
                ws.Cells(R, 4).Value = .Text
              Case "pubDate"
                ws.Cells(R, 1).Value = CDate(Mid(.Text, 1, 10))
              Case "description"
                ws.Cells(R, 3).Value = .Text
                '最後に出力されるのがdescriptionなので、R+1として
                'セル書込み開始行をシフトさせる
                R = R + 1
            End Select
           End With
        Next j
jmp:
    Next i
   
    'mRnage,mObj,ws,itemElementオブジェクトの解放
    Set itemElement = Nothing
    Set ws = Nothing
    Set mRange = Nothing
    Set mObj = Nothing
    
    '更新完了のメッセージ表示とメッセージボックスを
    '5秒間表示後に自動的に閉じる処理
    Call Erase_Msgbox
    
End Sub

こちらは実際にRSSフィードを取得して必要な要素をSheet1のセルに書込んでいきますので Set ws = ThisWorkbook.Sheets(“Sheet1”)のようにワークシートオブジェクトとして設定しています。

この取得したデータを書き込んでいくシート設定はActiveSheetとしても動作上は問題はないのですが、更新タイミングで開いているシートに対して処理を行うので使い勝手は悪いですから、定期更新などを行う際は使用Sheetを設定した方が良いと思います。

次にItem要素の取得と更新日付データの書込み（セルA3）を行います。取得したデータの書込み開始位置はws.Cells(Rows.Count, “A”).End(xlUp).Row + 1で対象シートA列の最下行を抽出しますので、新しい内容は順次追加されていくような形になります。

また書込む際に重複データを判定する上でSet mRange = ws.Range(“B5:B1048576”)のようにRangeオブジェクトとして検索対象範囲を設定しています。

後はループ処理を用いてItemの子要素であるtitle/pubDate/link/descriptionを抽出してセルにそれぞれ書き込み処理を行いますが、このサンプルで対象にしているURLでは最初にtitleから読み込まれるので重複検索と判定もSelect Caseの中で合わせて処理を行っています。

Case “title”

keyword = .Text
Set mObj = mRange.Find(keyword, LookAt:=xlWhole)
If mObj Is Nothing Then
ws.Cells(R, 2).Value = .Text
Else
GoTo jmp:
End If

この辺りの要素内容などはエクセルのXMLファイル対応付けなどを行うと視覚的に構成がわかるので参考になると思います。

ループ処理完了後は使用したオブジェクト変数の解放を行い、更新完了を知らせるメッセージボックス表示プロシージャを実行させます。

◆Module2・・・メッセージボックス表示とオートクローズ

Private Declare Function MessageBoxTimeoutA Lib "User32" _
(ByVal Hwnd As Long, _
ByVal lpText As String, _
ByVal lpCaption As String, _
ByVal uType As VbMsgBoxStyle, _
ByVal wLanguageID As Long, _
ByVal dwMilliseconds As Long) As Long

Sub Erase_Msgbox()
'※※API（MessageBoxTimeoutA）を使用して
'　      メッセージボックスを自動的に閉じる※※

Dim Rtn As Long

'構文：Rtn=MessageBoxTimeoutA(0&,Text,Title,Type,0&,Milliseconds)
'引数は全て必須になります
'　　Text ：　メッセージボックスに表示する文字列
'　　Title :　メッセージボックスのタイトル文字列
'　　Type :　 メッセージボックスへの表示ボタンやアイコン種類など
'　  Milliseconds :　メッセージボックスが自動的に閉じるまでの時間(ミリ秒）

Rtn = MessageBoxTimeoutA(0&, "RSS更新完了！", Application.Name, _
vbOKOnly + vbInformation + vbMsgBoxSetForeground, 0&, 5000)

'Rtnには戻り値（OKボタン=1、TimeOut=32000など）が入りますが、
'メッセージのオートクローズが目的なので特に使用しません

End Sub

これはお知らせ機能なので敢えて設定しなくても問題ないのですが、個人的には動作完了と毎回しっかり動いていることを確認する目的で設定しています。

メッセージ表示だけならModule1のRSS_UpDate( )にMsgBox ”更新完了！”で済みますが、自動的に閉じるようにしたい場合は少し記述が必要です。いつもなら他の記事でも使用しているWSHのPopupを使う所でしたがどうにも上手く動作しない（自動的に閉じない）ので、今回はAPIのMessageBoxTimeoutAを使っています。

この構文や概要はコメントに記述している通りですので、自動的にメッセージボックスを閉じたい場合には参考になるかと思います。

◆ワークブックモジュール

これはVBエディターのツリー上にあるThisWorkbook（ワークブックモジュール）に記述する内容になります。

Private Sub Workbook_Open()
    Call RSS_Check
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Application.OnTime onTimer, "RSS_Check", , False
End Sub

ここで実行しているのはブックを開いた際にRSS_Checkプロシージャを自動的に実行させていることと、ブックを閉じる際に自動更新として設定したonTimeメソッドを解除させています。ここを解除しておかないとファイルを閉じてもExcelが起動している間は延々と繰り返し実行されてしまうので注意が必要です。

以上がサンプルコードの内容になります。