このマクロは、対象サイトの都合で使用不可になりました。
Sub MyXlNhkEng()
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Rem NHK英語版サイト[ニュース]ページ読み込み処理
  Rem （HttpRequest使用）
  Rem 作譜：Hitrock Camellia Shinopy
  Rem 言語：Excel VBA
  Rem 機能...
  Rem   NHK英語版サイトの[ニュース]ページを取り込みし、
  Rem   Excelシートに書き込みする。
  Rem 注記...
  Rem   MyXlNhkEngを起動して使用｡
  Rem 履歴...
  Rem   第1版：2006/09/18：作成。
  Rem   第2版：2006/11/11：IE7に対応：「about:blank」を「about:」に変更した箇所あり。
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Rem 参照設定する場合...
  Rem   Microsoft Internet Controls
  Rem   Microsoft HTML Object Library
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Dim myHTTP As Variant ' IXMLHTTPRequest
  Dim myIE As Variant ' InternetExplorer
  Dim myDoc As Variant ' MSHTML.HTMLDocument
  '
  Dim myTagTds As Variant ' DispHTMLElementCollection
  Dim myTagTd As Variant ' HTMLDivElement
  '
  Dim rr As Long
  Dim myCount As Long
  Dim myDate As String
  Dim myText As String
  Dim myString As String
  '
  Dim myURL As String
  Dim myURLeng As String
  Dim myHref As String
  Dim myStatusBar As String
  '
  Dim c  As Long
  Dim i  As Long
  Dim myAns  As Long
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  Assistant.Visible = True
  With Assistant.NewBalloon
    .Animation = msoAnimationIdle
    .Icon = msoIconAlertQuery
    .Button = msoButtonSetCancel
    .Heading = "NHK英語版サイト" & vbCr _
      & "[ニュース]ページ" & vbCr _
      & "取り込み処理"
    .Text = "処理を実行しますか？　　　　"
    .Labels(1).Text = "[実行]"
    myAns = .Show
  End With
  Assistant.Visible = False
  If myAns = msoBalloonButtonCancel Then Exit Sub
  '
  Rem NHK英語サイト[ニュース]ページ
  myURLeng = "http://www.nhk.or.jp/daily/english/"
  myURL = myURLeng & "index2.html"
  '
  Sheets(1).Activate
  ActiveSheet.Range("A1").Select
  Application.CommandBars("Task Pane").Visible = False
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  Set myHTTP = CreateObject("MSXML2.XMLHTTP") ' ("Microsoft.XMLHTTP")
  Set myIE = CreateObject("InternetExplorer.Application")
  '
  With myIE
    .Navigate "about:blank"
    '.Document.Charset = "unicode"
    .Visible = False ' True
    Do While .Busy
      DoEvents
    Loop
    myStatusBar = "□NHK英語版サイト[ニュース]ページ 取り込み開始"
    Application.StatusBar = "MyXlNhkEng: " & myStatusBar
    DoEvents
    Set myDoc = .Document
  End With
  '
  Call myHTTP.Open("GET", myURL, False)
  Call myHTTP.Send
  If myHTTP.readyState <> 4 Then ' 4:READYSTATE_COMPLETE
    myStatusBar = "接続できません。" & vbCr & myHTTP.statusText & vbCr
    myStatusBar = myStatusBar & "myHTTP.readyState: " & myHTTP.readyState & vbCr
    myStatusBar = myStatusBar & "URL: " & myURL
    MsgBox myStatusBar, vbOKOnly, "MyXlNhkEng"
    GoTo MyXlNhkEngSubExit
  End If
  If myHTTP.Status <> 200 Then
    myStatusBar = "接続できません。" & vbCr & myHTTP.statusText & vbCr
    myStatusBar = myStatusBar & "myHTTP.Status: " & myHTTP.Status & vbCr
    myStatusBar = myStatusBar & "URL: " & myURL
    MsgBox myStatusBar, vbOKOnly, "MyXlNhkEng"
    GoTo MyXlNhkEngSubExit
  End If
  '
  myText = StrConv(myHTTP.responseBody, vbUnicode)
  myText = Replace(myText, " src=", " Zzzsrc=")
    '
  myString = "<td id=" & Chr(34) & "Date" & Chr(34) & ">"
  myText = Replace(myHTTP.responseText, "<td class=" & Chr(34) & "Date" & Chr(34) & ">", myString)
  myDoc.write myText
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  rr = 2
  Cells(rr, "A").Value = myDoc.Title
  Cells(rr, "B").Value = myURL
  Cells(rr, "A").Select
  ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:=myURL, TextToDisplay:=myDoc.Title
  '
  c = 0
  Set myTagTds = myDoc.getElementsByTagName("td")
  If myTagTds.Length = 0 Then
    Cells(rr, "B").Value = "更新日時がありません。"
  Else
    For Each myTagTd In myTagTds
      c = c + 1
      Select Case myTagTd.ID
        Case "Date"
          myDate = myTagTd.innerText
          Cells(rr, "B").Value = myDate
          Exit For
      End Select
      myStatusBar = "□NHK英語版サイト[ニュース]ページ 取り込み中："
      myStatusBar = myStatusBar & " ○ 更新日時 " & c & "/" & myTagTds.Length
      Application.StatusBar = "MyXlNhkEng: " & myStatusBar
    Next ' myTagTds
  End If
  Columns("A:A").ColumnWidth = 40#
  Columns("B:B").ColumnWidth = 70#
  '
  ' Application.ScreenUpdating = False
  myDoc.Title = myURLeng
  Rem ニュース本文の取り込み
  Call MyXlNhkEngPage(rr, myHTTP, myIE)
  For i = 4 To rr
    myDoc.Title = Cells(i, "B").Value
    Call MyXlNhkEngBody(i, myHTTP, myIE)
  Next ' i
  Application.ScreenUpdating = True
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  Sheets(1).Activate
  ActiveSheet.Range("B1").Select
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
MyXlNhkEngSubExit:
  Sheets(1).Activate
  myStatusBar = "処理が終了しました。"
  Application.StatusBar = "MyXlNhkEng: " & myStatusBar & Now()
  Application.Speech.Speak myStatusBar, False
  '
  myIE.Visible = True
  myIE.Quit
  Application.ScreenUpdating = True
  Beep
  '
  Set myHTTP = Nothing
  Set myIE = Nothing
  Set myDoc = Nothing
End Sub ' MyXlNhkEng *----*----*    *----*----*    *----*----*    *----*----*

Sub MyXlNhkEngPage(rr As Long, myHTTP As Variant, myIE As Variant)
  Dim myDoc As Variant ' MSHTML.HTMLDocument
  Dim myTagDivs As Variant ' DispHTMLElementCollection
  Dim myTagDiv As Variant ' HTMLDivElement
  Dim myLink As Variant ' MSHTML.HTMLAnchorElement
  '
  Dim myText As String
  Dim myString As String
  '
  Dim myURL As String
  Dim myURLeng As String
  Dim myHref As String
  Dim myStatusBar As String
  '
  Dim i As Long
  Dim c As Long
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  rr = rr + 1
  myURLeng = myIE.Document.Title
  myURL = myIE.Document.Title & "dailynews.html"
  '
  With myIE
    .Navigate "about:blank"
    .Visible = False ' True
    Do While .Busy
      DoEvents
    Loop
    DoEvents
    Set myDoc = myIE.Document
  End With
  myStatusBar = "□NHK英語版サイト[ニュース]ページ 取り込み中"
  '
  Call myHTTP.Open("GET", myURL, False)
  Call myHTTP.Send
  If myHTTP.readyState <> 4 Then ' 4:READYSTATE_COMPLETE
    myStatusBar = "接続できません。" & vbCr & myHTTP.statusText & vbCr
    myStatusBar = myStatusBar & "myHTTP.readyState: " & myHTTP.readyState & vbCr
    myStatusBar = myStatusBar & "URL: " & myURL
    MsgBox myStatusBar, vbOKOnly, "MyXlNhkEng"
    GoTo MyXlNhkEngPageSubExit
  End If
  If myHTTP.Status <> 200 Then
    myStatusBar = "接続できません。" & vbCr & myHTTP.statusText & vbCr
    myStatusBar = myStatusBar & "myHTTP.Status: " & myHTTP.Status & vbCr
    myStatusBar = myStatusBar & "URL: " & myURL
    MsgBox myStatusBar, vbOKOnly, "MyXlNhkEng"
    GoTo MyXlNhkEngPageSubExit
  End If
  '
  myText = StrConv(myHTTP.responseBody, vbUnicode)
  myText = Replace(myText, " src=", " Zzzsrc=")
  myDoc.write myText
  '
  c = 0
  For Each myLink In myDoc.Links
    c = c + 1
    If Len(myLink.innerText) <> 0 Then
      rr = rr + 1
      Cells(rr, "A").Select
      ' myHref = Replace(myLink.href, "about:blank.", Left(myURLeng, Len(myURLeng) - 1)) ' IE6以前
      myHref = Replace(myLink.href, "about:.", Left(myURLeng, Len(myURLeng) - 1))
      ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:=myHref, TextToDisplay:=myLink.innerText
      Cells(rr, "B").Value = myHref
    End If
    myStatusBar = "□NHK英語版サイト[ニュース]ページ 取り込み中："
    myStatusBar = myStatusBar & " ○ 記事 " & c & "/" & myDoc.Links.Length
    Application.StatusBar = "MyXlNhkEng: " & myStatusBar
  Next ' myLink
  ActiveWindow.SmallScroll up:=rr
MyXlNhkEngPageSubExit:
  Rem
End Sub ' MyXlNhkEngPage *----*----*    *----*----*    *----*----*    *----*----*

Sub MyXlNhkEngBody(i As Long, myHTTP As Variant, myIE As Variant)
  Dim myDoc As Variant ' MSHTML.HTMLDocument
  Dim myTagDivs As Variant ' DispHTMLElementCollection
  Dim myTagDiv As Variant ' HTMLDivElement
  Dim myLink As Variant ' MSHTML.HTMLAnchorElement
  '
  Dim myText As String
  Dim myString As String
  '
  Dim myURL As String
  Dim myURLeng As String
  Dim myHref As String
  Dim myStatusBar As String
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  myURL = myIE.Document.Title
  '
  With myIE
    .Navigate "about:blank"
    .Visible = False ' True
    Do While .Busy
      DoEvents
    Loop
    DoEvents
    Set myDoc = myIE.Document
  End With
  myStatusBar = "□NHK英語版サイト[ニュース]ページ 取り込み中："
  '
  Call myHTTP.Open("GET", myURL, False)
  Call myHTTP.Send
  If myHTTP.readyState <> 4 Then ' 4:READYSTATE_COMPLETE
    myStatusBar = "接続できません。" & vbCr & myHTTP.statusText & vbCr
    myStatusBar = myStatusBar & "myHTTP.readyState: " & myHTTP.readyState & vbCr
    myStatusBar = myStatusBar & "URL: " & myURL
    MsgBox myStatusBar, vbOKOnly, "MyXlNhkEng"
    GoTo MyXlNhkEngBodySubExit
  End If
  If myHTTP.Status <> 200 Then
    myStatusBar = "接続できません。" & vbCr & myHTTP.statusText & vbCr
    myStatusBar = myStatusBar & "myHTTP.Status: " & myHTTP.Status & vbCr
    myStatusBar = myStatusBar & "URL: " & myURL
    MsgBox myStatusBar, vbOKOnly, "MyXlNhkEng"
    GoTo MyXlNhkEngBodySubExit
  End If
  '
  myText = StrConv(myHTTP.responseBody, vbUnicode)
  myText = Replace(myText, " src=", " Zzzsrc=")
  myDoc.write myText
  '
  myText = myDoc.body.innerText
  myText = Replace(myText, vbCrLf & vbCrLf, "", 1, 1)
  Cells(i, "B").Value = myText
  '
  myStatusBar = "□NHK英語版サイト[ニュース]ページ 取り込み中："
  myStatusBar = myStatusBar & " ○ 記事 " & i
  Application.StatusBar = "MyXlNhkEng: " & myStatusBar
MyXlNhkEngBodySubExit:
  Rem
End Sub ' MyXlNhkEngBody *----*----*    *----*----*    *----*----*    *----*----*