Option Explicit
Private Sub testParse()
Dim url As String
url = "http://www.morningstar.co.jp/FundData/common/chart/xml/all/MSCI011010.xml"
Application.StatusBar = "Loading: " & url
Dim xdoc As New DOMDocument60
xdoc.async = False
xdoc.Load url
Application.StatusBar = ""
If (xdoc.parseError.ErrorCode <> 0) Then 'ロード失敗
Debug.Print xdoc.parseError.reason 'エラー内容を出力
Exit Sub
End If
Dim code As IXMLDOMNode
Set code = xdoc.SelectSingleNode("//morningstarXML/fund/@code")
Debug.Print code.Text
Dim name As IXMLDOMNode
Set name = xdoc.SelectSingleNode("//morningstarXML/fund/@name")
Debug.Print name.Text
Dim period_end As IXMLDOMNode
Set period_end = xdoc.SelectSingleNode("//morningstarXML/fund/@period_end")
Debug.Print period_end.Text
'//morningstarXML/fund/@name //morningstarXML/fund/@period_end
Dim days As IXMLDOMNodeList
Set days = xdoc.SelectNodes("//day")
Debug.Print days.Length
Dim day As IXMLDOMNode
For Each day In days
Dim attr As IXMLDOMNamedNodeMap
Set attr = day.Attributes
Dim year As String
year = attr.getNamedItem("year").Text
Dim month As String
month = attr.getNamedItem("month").Text
Dim value As String
value = attr.getNamedItem("value").Text
Dim price As String
price = attr.getNamedItem("price").Text
Dim volume As String
volume = attr.getNamedItem("volume").Text
Dim return_value As String
return_value = attr.getNamedItem("return_value").Text
Dim indication As String
indication = attr.getNamedItem("indication").Text
Dim work_end As String
work_end = ""
Dim node As IXMLDOMNode
Set node = attr.getNamedItem("work_end")
If Not node Is Nothing Then
work_end = node.Text
End If
Next
End Sub
Private Sub testLoadIndex()
Dim bk As Workbook
Dim sht As Worksheet
Set bk = ThisWorkbook
LoadIndex "NYGL00100", bk.Sheets("Sheet48") 'bk.Sheets.Add
End Sub
Public Sub LoadAllIndex()
Dim shts As Sheets
Set shts = ThisWorkbook.Sheets
Dim sht As Worksheet
Set sht = shts("index_list")
Dim area As Range
Set area = sht.Range("B:B").SpecialCells(xlCellTypeConstants)
Dim cur As Range
For Each cur In area
Debug.Print cur.value
LoadIndex cur.value, shts.Add(after:=shts(shts.Count))
Next
End Sub
Sub LoadIndex(indexCode As String, sht As Worksheet)
Dim url As String
url = "http://www.morningstar.co.jp/FundData/common/chart/xml/all/" & indexCode & ".xml"
Application.StatusBar = "Loading: " & url
Dim xdoc As New DOMDocument60
xdoc.async = False
xdoc.Load url
Debug.Print url
Application.StatusBar = ""
If (xdoc.parseError.ErrorCode <> 0) Then 'ロード失敗
MsgBox xdoc.parseError.reason 'エラー内容を出力
Exit Sub
End If
Dim code As IXMLDOMNode
Set code = xdoc.SelectSingleNode("//morningstarXML/fund/@code")
Debug.Print code.Text
Dim name As IXMLDOMNode
Set name = xdoc.SelectSingleNode("//morningstarXML/fund/@name")
Debug.Print name.Text
Dim indexName As String
indexName = name.Text
Dim period_end As IXMLDOMNode
Set period_end = xdoc.SelectSingleNode("//morningstarXML/fund/@period_end")
Debug.Print period_end.Text
Dim days As IXMLDOMNodeList
Set days = xdoc.SelectNodes("//day")
Debug.Print days.Length
Application.ScreenUpdating = False
Dim Calculation As XlCalculation
Calculation = Application.Calculation
Application.Calculation = xlCalculationManual
sht.UsedRange.Delete xlToLeft
Dim cur As Range
Set cur = sht.Range("B2")
cur.Offset(, 0).value = "Code"
With cur.Offset(, 1).Resize(, 5)
.HorizontalAlignment = xlLeft
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.MergeCells = True
End With
cur.Offset(, 1).value = code.Text
Set cur = cur.Offset(1)
cur.Offset(, 0).value = "Name"
With cur.Offset(, 1).Resize(, 5)
.HorizontalAlignment = xlLeft
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.MergeCells = True
End With
cur.Offset(, 1).value = name.Text
Set cur = cur.Offset(1)
cur.Offset(, 0).value = "Period End"
With cur.Offset(, 1).Resize(, 5)
.HorizontalAlignment = xlLeft
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.MergeCells = True
End With
cur.Offset(, 1).value = period_end.Text
Set cur = cur.Offset(2)
cur.Offset(, 0).value = "Date"
cur.Offset(, 1).value = "Price"
cur.Offset(, 2).value = "Volume"
cur.Offset(, 3).value = "Return Value"
cur.Offset(, 4).value = "Indication"
cur.Offset(, 5).value = "Work End"
Dim header As Range
Set header = sht.Range(cur, cur.Offset(, 255).End(xlToLeft))
Dim i As Long
Dim l As Long
l = days.Length - 1
For i = 0 To l
Application.StatusBar = indexName & "; " & i & " / " & l
Dim day As IXMLDOMNode
Set day = days(i)
Dim attr As IXMLDOMNamedNodeMap
Set attr = day.Attributes
Dim year As String
year = attr.getNamedItem("year").Text
Dim month As String
month = attr.getNamedItem("month").Text
Dim value As String
value = attr.getNamedItem("value").Text
Dim price As String
price = attr.getNamedItem("price").Text
Dim volume As String
volume = attr.getNamedItem("volume").Text
Dim return_value As String
return_value = attr.getNamedItem("return_value").Text
Dim indication As String
indication = attr.getNamedItem("indication").Text
Dim work_end As String
work_end = ""
Dim node As IXMLDOMNode
Set node = attr.getNamedItem("work_end")
If Not node Is Nothing Then
work_end = node.Text
End If
Set cur = cur.Offset(1)
cur.Offset(, 0).value = year & "/" & month & "/" & value
cur.Offset(, 1).value = price
cur.Offset(, 2).value = volume
cur.Offset(, 3).value = return_value
cur.Offset(, 4).value = indication
cur.Offset(, 5).value = work_end
Next
header.Font.Bold = True
With header
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With header.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 16777164
.TintAndShade = 0
.PatternTintAndShade = 0
End With
header.AutoFilter
header.EntireColumn.AutoFit
Application.StatusBar = False
Application.ScreenUpdating = True
Application.Calculation = Calculation
Dim s As Worksheet
On Error Resume Next
Set s = sht.Parent.Sheets(Left(indexName, 31))
On Error GoTo 0
If s Is Nothing Then
sht.name = Left(indexName, 31)
Else
If vbOK = MsgBox("シートが重複しています。削除しますか？", vbOKCancel) Then
s.Delete
sht.name = Left(indexName, 31)
End If
End If
End Sub
Private Sub showSheetNames()
Dim sht As Worksheet
For Each sht In ThisWorkbook.Sheets
Debug.Print sht.name
Next
End Sub
