VBA로 RSS XML 데이터 읽어오기

지식인 링크: https://kin.naver.com/qna/detail.nhn?d1id=1&dirId=102&docId=316777745&page=1#answer1

RSS  XML데이터를 읽는 방법은 여러가지입니다.

VBA 없이 손쉽게 읽어 오는 방법은

먼저 개발도구의 '원본'을 눌러서

RSS 주소를 넣어주고

RSS 트리가 불러와 지면

item 폴더를 끌어서 셀에 갖다 놓고

우클릭해서 '갱신'을 선택해주면

RSS 내용을 필터형식으로 조회할 수 있습니다.

그 과정을 VBA를 이용한다면 Workbook.XmlImport를 이용해서 아래와 같습니다.

Sub Xml_Import()
    Dim str As String
    On Error Resume Next
    Application.DisplayAlerts = False
    
    str = "스마트시티"
 
    ActiveWorkbook.XmlMaps(str).Delete
    ActiveWorkbook.XmlImport URL:= _
        "http://newssearch.naver.com/search.naver?where=rss&query=" & str _
        , ImportMap:=Nothing, Overwrite:=True, Destination:=Range("$A$1")
    
    With ActiveWorkbook.XmlMaps.Item(ActiveWorkbook.XmlMaps.Count)
        .ShowImportExportValidationErrors = False
        .AdjustColumnWidth = False
        .PreserveColumnFilter = False
        .PreserveNumberFormatting = False
        .AppendOnImport = False
        .Name = str
        '.DataBinding.Refresh
    End With
    Range("A:J").Delete
    UsedRange.Columns.AutoFit = False
'    ActiveWorkbook.XmlMaps(str).DataBinding.Refresh
End Sub

또다른 방법으로 비슷하지만 XmlMap을 이용할 수도 있습니다.

Sub AddXmlMap()
 
    Dim str As String
    
    str = "스마트시티"
    On Error Resume Next
    Application.DisplayAlerts = False
    Range("A1").Select
    With ActiveWorkbook.XmlMaps
    
        For i = .Count To 1 Step -1: .Item(i).Delete: Next i
    
        .Add "http://newssearch.naver.com/search.naver?where=rss&query=" & ENCODEURL(str), "rss"
        .Item(.Count).Name = str
        
    End With
    With ActiveWorkbook.XmlMaps(str)
        .ShowImportExportValidationErrors = False
        .AdjustColumnWidth = False
        .DataBinding.Refresh
    End With
 
'    Range("A1:A55").XPath.SetValue ActiveWorkbook.XmlMaps(str), "/rss/channel/item/title"
'    Range("B1:B55").XPath.SetValue ActiveWorkbook.XmlMaps(str), "/rss/channel/item/link"
'    Range("C1:C55").XPath.SetValue ActiveWorkbook.XmlMaps(str), "/rss/channel/item/description"
'    Range("D1:D55").XPath.SetValue ActiveWorkbook.XmlMaps(str), "/rss/channel/item/pubDate"
'    ActiveWorkbook.XmlMaps(str).DataBinding.Refresh
End Sub

특히 이 방법에서는 Xpath 를 이용하여

특정 셀에 특정 Rss 데이터를 넣어줄 수 있습니다.

마지막으로 XML 데이터를 XML라이브러리를 이용해서 직접 Parsing 할 수도 있겠습니다.

MSXML2.XMLDOMDocument 를 이용하여

childNode 들을 순환하면서 테이블 구조를 만드는 것입니다.

저는 조금 복잡하지만 마지막 방법을 이용해 보았습니다.

다소 길지만 매크로 코드는 아래와 같습니다.

'RSS XML Data Reading Example
'by koanhn
 
 
Option Explicit
 
Sub GetXMLSheet()
    
    Dim i As Long
    Dim StartTime As Single
    Dim Cnt As Long
    Dim dSht As Worksheet
    
    StartTime = Timer
    Set dSht = Worksheets(1)
    ClearDefaultSheet
    
    For i = 2 To Worksheets.Count
        Cnt = getXML(Worksheets(i).Name)
        '검색어별로 최근 5개씩 복사
        Worksheets(i).Range("A2:E6").Copy dSht.Range("A2").Offset((i - 2) * 5)
    Next i
    
    dSht.Activate
    Application.StatusBar = "Processing time: " & Format(Timer - StartTime, "0.00 Sec")
    Application.OnTime Now + TimeValue("00:00:04"), "ResetStatusBar"
End Sub
 
Sub ClearDefaultSheet()
    Dim dSht As Worksheet
    Dim i As Long
    
    Set dSht = Worksheets(1)
    dSht.Rows("2:16").Clear
    dSht.Hyperlinks.Delete
    For i = dSht.Shapes.Count To 1 Step -1
        If dSht.Shapes(i).Name Like "Thumb_*" Then dSht.Shapes(i).Delete
    Next i
End Sub
 
Function ResetStatusBar()
    Application.StatusBar = False
End Function
 
'For early binding, go to menu 'Tools - Reference' and add reference to 'MSXML 6.0'
'For late binding, define variables as Object type and use CreateObject()
Function getXML(SearchStr As String) As Integer
    Dim XDoc As Object  'MSXML2.DOMDocument
    Dim xresult As Object  'As MSXML2.IXMLDOMNode
    Dim xentry As Object  'As MSXML2.IXMLDOMNode
    Dim xChild As Object  'As MSXML2.IXMLDOMNode
    Dim xxChild As Object  'As MSXML2.IXMLDOMNode
    
    Dim wb As Workbook, sht As Worksheet
    Dim Col As Long, Row As Long, x As Integer
    Dim xItem() As String
    Const NodeCols = 7 ' 제목, 링크  등 7개 항목
    Dim NodeRows As Integer
    
    getXML = 0
    'Set XDoc = New MSXML2.DOMDocument
    Set XDoc = CreateObject("MSXML2.DOMDocument")
    If XDoc Is Nothing Then GoTo Oops
    
    'SearchStr = "스마트시티"
    XDoc.async = False
    XDoc.validateOnParse = False
    XDoc.Load ("http://newssearch.naver.com/search.naver?where=rss&query=" & ENCODEURL(SearchStr))
    'LoadOption = xlXmlLoadImportToList
    
    Set xresult = XDoc.DocumentElement
    'Set xentry = xresult.FirstChild
    
    '시트 초기화
    Set sht = Worksheets(SearchStr)
    If sht Is Nothing Then GoTo Oops
    sht.Activate
    sht.Cells.Clear
    sht.Hyperlinks.Delete
    For x = sht.Shapes.Count To 1 Step -1
        If sht.Shapes(x).Name Like "Thumb_*" Then sht.Shapes(x).Delete
    Next x
    Application.StatusBar = False
    
    Col = 1
    Row = 2
    sht.Range("A1:E1") = Array("Keyword", "Title", "Date", "Author", "Thumb")
    
    'item 만 가져오기
    Set xentry = XDoc.SelectNodes("//rss/channel/item")
    NodeRows = xentry.Length
        
    'Debug.Print NodeRows
    For Each xChild In xentry
 
        Col = 1
        ReDim xItem(1 To NodeCols)
        For Each xxChild In xChild.ChildNodes
            If xxChild.BaseName = "thumbnail" Then
                xItem(Col) = xxChild.Attributes.getNamedItem("url").Text
            Else
                xItem(Col) = xxChild.Text
                'Debug.Print xChild.BaseName & " " & xxChild.XML
            End If
            Col = Col + 1
        Next xxChild
        sht.Cells(Row, 1) = SearchStr
        sht.Cells(Row, 2) = getXtime(xItem(4))     '날짜
        sht.Cells(Row, 2).NumberFormat = "mm/dd"
        sht.Cells(Row, 3) = xItem(1)    '제목
        sht.Hyperlinks.Add sht.Cells(Row, 3), xItem(2), , xItem(3) ' 하이퍼링크
        sht.Cells(Row, 4) = xItem(5)    '작성자, xItem(6)= Category 생략
        'sht.Cells(Row, 5) = xItem(7)    'Thumbnail
        
        'Thumbnail 삽입 - 속도 느려짐
        If Row < 7 And Len(xItem(7)) Then
            '파일에 포함, 연결로 삽입
            With sht.Shapes.AddPicture(xItem(7), True, True, _
                sht.Cells(Row, 5).Left, sht.Cells(Row, 5).Top, _
                sht.Cells(Row, 5).Width, sht.Cells(Row, 5).Height)
                .Name = "Thumb_" & sht.Index & "_" & (Row - 1)
                .Placement = xlMoveAndSize
            End With
        End If
        Row = Row + 1
        
        Application.StatusBar = "Searching " & SearchStr & " - " & _
            Format(((Row - 2) * 100) / NodeRows, "00.0") & " % "
            'Debug.Print Row - 1, NodeRows
    Next xChild
    getXML = NodeRows
    'sht.Columns.AutoFit
Oops:
    Set XDoc = Nothing
    'Application.StatusBar = False
End Function
 
'XML 시간을 일반 시간으로 변환
Function getXtime(xstr As String) As String
    Dim str As String
    
    str = Mid(xstr, InStr(xstr, " ") + 1)
    str = Left(str, InStrRev(str, " ") - 1)
    getXtime = str
End Function
 
'검색어 인코딩 손상 방지
Function ENCODEURL(varText As Variant, Optional blnEncode = True)
    Static objHtmlfile As Object
    If objHtmlfile Is Nothing Then
        Set objHtmlfile = CreateObject("htmlfile")
        With objHtmlfile.parentWindow
            .execScript "function encode(s) {return encodeURIComponent(s)}", "jscript"
        End With
    End If
    If blnEncode Then
        ENCODEURL = objHtmlfile.parentWindow.encode(varText)
    End If
End Function
 

실행 화면입니다.

먼저 원하는 검색어의 이름으로 시트를 추가합니다.

Default 시트에서

Load RSS 를 누르면 

Default를 제외한 모든 시트에서 시트이름을 검색어로 RSS 자료를 각 시트별로 가져옵니다.

하단 상태바에 진척률을 표시해줍니다.

모두 로딩되면 

Default 시트에 5개씩만 복사하도록 해보았습니다.

샘플 파일 첨부합니다.

RSSGetXML2.xlsm

추가)

xmlDoc.SelectNodes("//rss/item")가 값을 리턴하지 않을 경우

xml NameSpace 옵션을 필요로 합니다.

참고:

https://stackoverflow.com/questions/20032610/vba-excel-selectsinglenode-syntax

https://techsupt.winbatch.com/webcgi/webbatch.exe?techsupt/nftechsupt.web+WinBatch/XML+XML~selectNodes~Sample.txt