VBAでYahoo NewsのRSSを取り込んでみる

目的

RSSを読み込むという処理を行ったことがなかったので試したときのメモ
※タイマーどうするんだろうと思ったら、こういう方法もあるのか・・

VBAのサンプルコード

ツール -> 参照設定で「Microsoft XML, v6.0」をチェックする

Sub Samp001()

    Dim xmlObj      As MSXML2.DOMDocument60
    Dim nlst        As MSXML2.IXMLDOMNodeList
    Dim node        As MSXML2.IXMLDOMNode
    Dim rngFind     As Range
    Dim hyplink     As Hyperlink
    Dim genTime     As Date
    Dim lngRow      As Long
    Dim intCnt      As Integer
    Dim url         As String
    Dim xml         As String
    Dim strTitle    As String
    Dim strLink     As String
    Dim strDate     As String
    Dim strComm     As String
'
Debug.Print Now
'
    Set xmlObj = New MSXML2.DOMDocument60
    xmlObj.async = False
    xmlObj.validateOnParse = False
'
    url = "https://news.yahoo.co.jp/rss/topics/top-picks.xml"
    xml = WorksheetFunction.WebService(url)
'
    xmlObj.LoadXML xml
    '
    '   取り込んだデータを確認する
    '
    '    Debug.Print xmlObj.xml
    
    '   Debug用
    '
'    xmlObj.Load ("C:\Data\rss.xml")
    Set node = xmlObj.SelectSingleNode("//channel")
    '
    'Debug.Print node.ChildNodes(2).Text
    '
    '   pubDateの取得
    '
    genTime = CDate(Mid(node.ChildNodes(2).Text, 5, 20))
'
    Set nlst = xmlObj.SelectNodes("//channel//item")
    '
    '   node数
    '
'    Debug.Print nlst.Length
    lngRow = 3
    '
    '   RSSの今回のpubDate : GMT -> JST 変換
    '
    ActiveSheet.Cells(lngRow, 1) = Format(DateAdd("h", 9, CDate(genTime)), "yyyy/mm/dd hh:MM:ss")
    '
    ' ループで処理する
    '
    For Each node In nlst
        strTitle = Trim(node.ChildNodes(0).Text)
        strLink = Trim(node.ChildNodes(1).Text)
        strDate = Trim(DateAdd("h", 9, CDate(Mid(node.ChildNodes(2).Text, 5, 20))))
        '
        '   コメントはnode.ChildNodes.Length = 4 であることに対応
        '
        If node.ChildNodes.Length > 3 Then
            strComm = node.ChildNodes(3).Text
        Else
             strComm = "no comments"
        End If
'
        With ActiveSheet
            '
            '   strTitleがWorkSheetに存在するか
            '
            Set rngFind = Range(.Cells(3, 2), .Cells(Rows.Count, 2)) _
                            .Find(What:=strTitle, LookAt:=xlWhole)
'
            If Not rngFind Is Nothing Then
                '
                '   既に登録済の場合はskip
                '
'                Debug.Print "見つかった : " & rngFind.Address
            Else
                '
                '   A列でpubDateが書かれている最下行を取得する
                '
                lngRow = .Range("A" & Rows.Count).End(xlUp).Row
                '
                '   次行に書式を設定後pubDateを書き込む
                '
                lngRow = lngRow + 1
                .Range(.Cells(lngRow, 1), .Cells(lngRow, 1)).Select
                Selection.NumberFormatLocal = "yyyy/mm/dd"
                .Cells(lngRow, 1) = Format(strDate, "yyyy/mm/dd")
                '
                '   記事へのurl
                '
                Set hyplink = .Hyperlinks.Add(Anchor:=.Range(.Cells(lngRow, 2), .Cells(lngRow, 2)), _
                                                          Address:=strLink, _
                                                          TextToDisplay:=strTitle)
                '
                '   コメントへのurl
                '
                If node.ChildNodes.Length > 3 Then
                    '
                    '   コメントはnode.ChildNodes.Length = 4 であることに対応
                    '
                    Set hyplink = .Hyperlinks.Add(Anchor:=.Range(.Cells(lngRow, 3), .Cells(lngRow, 3)), _
                                                              Address:=strComm, _
                                                              TextToDisplay:="Comments")
                Else
                     .Cells(lngRow, 3) = strComm
                End If
            End If
        End With
    Next
'
    DoEvents
    onTimer = Now + TimeSerial(0, 5, 0)     'debug用に5分
    DoEvents
    Application.OnTime onTimer, "Samp001" 
'
End Sub

参考にしたのは以下のサイト

【VBA】RSSをMicrosoft XMLでセルに取り込む
Range.End プロパティ [Excel]
文字列としてのプロシージャー名を起動する方法（Run,OnTime）
Application.OnTime メソッド [Excel]
TimeSerial関数
excel - OnTimeが複数回実行されるのを防ぐ