このマクロは、対象サイトの都合で使用不可になりました。
Sub MyXlTokyoNpNews()
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Rem 東京新聞サイト[東京新聞の記事]ページ取り込み処理
  Rem 言語：Excel VBA
  Rem 機能...
  Rem   東京新聞サイトの[東京新聞の記事]ページを、[外部データの取り込み]とHttpRequestで取り込む。
  Rem 注記...
  Rem
  Rem 履歴...
  Rem   第01版：2007/02/18 作成。
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Rem 参照設定する場合...
  Rem   Microsoft Internet Controls
  Rem   Microsoft HTML Object Library
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Dim myCmmdBar As CommandBar
  Dim myCtrlBttn As CommandBarControl
  Dim myCtrlBttnDeTail As CommandBarControl
  Dim myCtrlBttnLastest As CommandBarControl
  Dim myCtrlBttnOk As CommandBarControl
  Dim myCtrlBttnCancel As CommandBarControl
  Dim x As Long
  Dim y As Long
  Dim myFaceId As Long
  Dim myCbox(1) As Boolean
  Dim myAns As Long
  Dim myMsg As String
  '
  Dim myMaxRow As Long
  Dim myName As String
  Dim i As Long
  Dim myFlag As Long
  Dim myFind As Variant
  Dim myStatusBar As String
  Dim myMax As Long
  '
  Dim myIE As Variant ' InternetExplorer
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  On Error Resume Next
  CommandBars("MyXlTokyoNpNews").Delete
  On Error GoTo 0
  '
  Set myCmmdBar = CommandBars.Add(Name:="MyXlTokyoNpNews", Position:=msoBarPopup, Temporary:=True)
  Set myCtrlBttn = myCmmdBar.Controls.Add(Type:=msoControlButton, Before:=1, Temporary:=True)
  Set myCtrlBttnDeTail = myCmmdBar.Controls.Add(Type:=msoControlButton, Before:=2, Temporary:=True)
  Set myCtrlBttnLastest = myCmmdBar.Controls.Add(Type:=msoControlButton, Before:=3, Temporary:=True)
  Set myCtrlBttnOk = myCmmdBar.Controls.Add(Type:=msoControlButton, Before:=4, Temporary:=True)
  Set myCtrlBttnCancel = myCmmdBar.Controls.Add(Type:=msoControlButton, Before:=5, Temporary:=True)
  '
  myMsg = "MyXlTokyoNpNews" & vbCrLf & vbCrLf
  myMsg = myMsg & "東京新聞サイト" & vbCrLf
  myMsg = myMsg & "[東京新聞の記事]ページ" & vbCrLf
  myMsg = myMsg & "取り込み処理" & vbCrLf & vbCrLf
  '
  With myCtrlBttn
    .DescriptionText = "東京新聞サイト[東京新聞の記事]ページ取り込み処理ポップアップメニュー"
    .Style = msoButtonIconAndWrapCaption
    .Caption = myMsg & "処理を実行しますか？"
    .TooltipText = "処理を実行しますか？"
    .FaceId = 1089
    myFaceId = .FaceId
  End With
  '
  With myCtrlBttnDeTail
    .DescriptionText = "[ニュースの本文も取り込む]ボタン"
    .BeginGroup = True
    .Style = msoButtonIconAndCaption
    .Caption = "ニュースの本文も取り込む"
    .TooltipText = "ニュースの本文は取り込まない。"
    .FaceId = 6963
    .OnAction = "MyXlTokyoNpNewsBttnMyDetail"
  End With
  '
  With myCtrlBttnLastest
    .DescriptionText = "[最新日のみ本文を取り込む]ボタン"
    .BeginGroup = True
    .Style = msoButtonIconAndCaption
    .Caption = "最新刊のみ本文を取り込む"
    .TooltipText = "最新刊のみ本文を取り込む。"
    .FaceId = 220
    .OnAction = "MyXlTokyoNpNewsBttnMyLastest"
  End With
  '
  With myCtrlBttnOk
    .DescriptionText = "[OK]ボタン"
    .BeginGroup = True
    .Style = msoButtonIconAndCaption
    .Caption = "OK"
    .TooltipText = "処理をを実行します。"
    .FaceId = 459
    .OnAction = "MyXlTokyoNpNewsBttnMyOk"
  End With
  '
  With myCtrlBttnCancel
    .DescriptionText = "[キャンセル]ボタン"
    .Style = msoButtonIconAndCaption
    .Caption = "キャンセル" & "　　　　　　　　　　　　"
    .TooltipText = "処理を中止します。"
    .FaceId = 330
    .OnAction = "MyXlTokyoNpNewsBttnMyCancel"
  End With
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  x = ActiveWindow.PointsToScreenPixelsX(0)
  y = ActiveWindow.PointsToScreenPixelsY(0)
  Beep
  Do
    On Error Resume Next
    myCmmdBar.ShowPopup x, y
    On Error GoTo 0
    DoEvents
    If myCmmdBar.Controls(1).FaceId <> myFaceId Then Exit Do
  Loop
  '
  Select Case myCmmdBar.Controls(1).FaceId
    Case 459
      myAns = vbOK
    Case 330
      myAns = vbCancel
  End Select
  '
  If myCmmdBar.Controls(2).FaceId = 220 Then
    myCbox(0) = True
  Else
    myCbox(0) = False
  End If
  '
  If myCmmdBar.Controls(3).FaceId = 220 Then
    myCbox(1) = True
  Else
    myCbox(1) = False
  End If
  '
  On Error Resume Next
  myCmmdBar.Delete
  On Error GoTo 0
  '
  If myAns = vbCancel Then Exit Sub
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  myStatusBar = "□東京新聞サイト[東京新聞の記事]ページ 取り込み開始"
  Application.StatusBar = "MyXlTokyoNpNews: " & myStatusBar
  '
  With ActiveSheet.QueryTables.Add(Connection:="FINDER;http://www.tokyo-np.co.jp/news.shtml", Destination:=Range("A1"))
    .Name = "news.shtml"
    .FieldNames = True
    .RowNumbers = False
    .FillAdjacentFormulas = False
    .PreserveFormatting = False
    .RefreshOnFileOpen = False
    .BackgroundQuery = False
    .RefreshStyle = xlInsertDeleteCells
    .SavePassword = False
    .SaveData = True
    .AdjustColumnWidth = True
    .RefreshPeriod = 0
    .WebSelectionType = xlSpecifiedTables
    .WebFormatting = xlWebFormattingAll
    .WebTables = "7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24"
    .WebPreFormattedTextToColumns = True
    .WebConsecutiveDelimitersAsOne = True
    .WebSingleBlockTextImport = False
    .WebDisableDateRecognition = False
    .WebDisableRedirections = False
    .Refresh BackgroundQuery:=False
  End With
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  ActiveCell.SpecialCells(xlLastCell).Select
  myMaxRow = ActiveCell.Row
  For i = 5 To myMaxRow
    If Range("A" & i).Interior.ColorIndex <> xlColorIndexNone Then
      Range("B" & i).Value = Range("A" & i).Value
      Range("B" & i).Font.Bold = True
      Range("B" & i).Interior.ColorIndex = 1
    End If
  Next ' i
  '
  Range("A1").Select
  myName = Range("B1").Value
  '
  For i = myMaxRow To 5 Step -1
    If Range("B" & i).Value = "" Then
      Range("B" & i).Select
      Selection.Delete Shift:=xlUp
    End If
  Next ' i
  '
  Range("B4").Select
  Application.FindFormat.Clear
  With Application.FindFormat.Interior
    .ColorIndex = 1
    .Pattern = xlSolid
  End With
  '
  Set myFind = Cells.Find(What:="", SearchFormat:=True)
  Do While Not myFind Is Nothing
    With myFind
      .Select
      .Interior.ColorIndex = 34
      .EntireRow.Insert
      .Offset(1, 0).Select
    End With
    Set myFind = Cells.Find(What:="", SearchFormat:=True)
  Loop
  Application.FindFormat.Clear
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  Range("B5:B" & myMaxRow).Select
  Selection.Copy
  Sheets.Add After:=Sheets(ActiveSheet.Name)
  ActiveSheet.Name = myName
  Selection.PasteSpecial Paste:=xlPasteColumnWidths
  ActiveSheet.Paste
  Range("A1").Select
  '
  ActiveSheet.Previous.Select
  Application.DisplayAlerts = False
  ActiveSheet.Delete
  Application.DisplayAlerts = True
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  Application.CommandBars("Task Pane").Visible = False
  Columns("A:A").ColumnWidth = 50
  ActiveWindow.Zoom = 75
  '
  If myCbox(0) = True Then
    ActiveSheet.UsedRange.Select
    ActiveCell.SpecialCells(xlLastCell).Select
    myMaxRow = ActiveCell.Row
    '
    myMax = myMaxRow
    For i = 3 To myMaxRow
      Range("A" & i).Select
      If Selection.Hyperlinks.Count <> 0 Then
        Range("B" & i).Value = Selection.Hyperlinks(1).Address
      End If
      If myCbox(1) = True Then
        If Range("B" & i).Value = "" Then
          myMax = i
          Exit For
        End If
      End If
    Next ' i
    '
    Set myIE = CreateObject("InternetExplorer.Application")
    Range("B1").Select
    For i = 3 To myMax
      If Range("B" & i).Value <> "" Then
        Range("B" & i).Select
        Call MyXlTokyoNpNewsBody(Range("B" & i).Value, myIE)
      End If
      myStatusBar = "□東京新聞サイト[東京新聞の記事]ページ 本文 取り込み中 "
      myStatusBar = myStatusBar & i * 100 \ myMax & "%　"
      myStatusBar = myStatusBar & i & "/" & myMax & "行　"
      Application.StatusBar = "MyXlTokyoNpNews: " & myStatusBar
      DoEvents
    Next ' i
    Rem myIE.Visible = True
    myIE.Quit
  End If
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  Range("A1").Select
  Application.ScreenUpdating = True
  myStatusBar = "処理が終了しました。"
  Application.StatusBar = "MyXlTokyoNpNews: " & myStatusBar & Now()
  Application.Speech.Speak myStatusBar, False
  '
  Set myIE = Nothing
End Sub ' MyXlTokyoNpNews *----*----*    *----*----*    *----*----*    *----*----*

Sub MyXlTokyoNpNewsBody(myURL As String, myIE As Variant)
  Dim myHTTP As Variant ' IXMLHTTPRequest
  Dim myDoc As Variant ' MSHTML.HTMLDocument
  Dim mySubTags As Variant ' DispHTMLElementCollection
  Dim mySubTag As Variant ' HTMLHeaderElement
  '
  Dim myText As String
  Dim myValue As String
  Dim myStatusBar As String
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  Set myHTTP = CreateObject("MSXML2.XMLHTTP") ' ("Microsoft.XMLHTTP")
  '
  With myIE
    .Navigate "about:blank"
    .Visible = False ' True
    Do While .Busy
      DoEvents
    Loop
    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, "MyXlKanaloco"
    GoTo MyXlTokyoNpNewsBodySubExit
  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, "MyXlKanaloco"
    GoTo MyXlTokyoNpNewsBodySubExit
  End If
  '
  myText = StrConv(myHTTP.responseBody, vbUnicode)
  myText = Replace(myText, "<LINK ", "<!-- LINK ", 1, 1)
  myText = Replace(myText, "<title>", " --> <title>", 1, 1)
  myText = Replace(myText, "<img ", "<!-- img ", 1, 2)
  myText = Replace(myText, "<script ", "<!-- script ", 1, 1)
  myText = Replace(myText, " src=", " Zzzsrc=")
  myText = Replace(myText, " SRC=", " Zzzsrc=")
  myText = Replace(myText, "<BR><BR>", "<BR>")
  myText = Replace(myText, "<br><br>", "<br>")
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  myDoc.write myText
  myDoc.Title = myURL
  myValue = ""
  With ActiveCell
    .ColumnWidth = 120
    .VerticalAlignment = xlTop
    .WrapText = True
  End With
  '
  If InStr(myText, "H2") < InStr(myText, "H3") Then
    Set mySubTags = myDoc.getElementsByTagName("H2")
    If Not mySubTags Is Nothing Then
      For Each mySubTag In mySubTags
        myValue = myValue & mySubTag.innerText & vbLf
      Next ' mySubTag
    End If
    Set mySubTags = myDoc.getElementsByTagName("H3")
    If Not mySubTags Is Nothing Then
      For Each mySubTag In mySubTags
        myValue = myValue & mySubTag.innerText & vbLf
      Next ' mySubTag
    End If
  Else
    Set mySubTags = myDoc.getElementsByTagName("H3")
    If Not mySubTags Is Nothing Then
      For Each mySubTag In mySubTags
        myValue = myValue & mySubTag.innerText & vbLf
      Next ' mySubTag
    End If
    Set mySubTags = myDoc.getElementsByTagName("H2")
    If Not mySubTags Is Nothing Then
      For Each mySubTag In mySubTags
        myValue = myValue & mySubTag.innerText & vbLf
      Next ' mySubTag
    End If
  End If
  '
  Set mySubTags = myDoc.getElementsByTagName("P")
  If Not mySubTags Is Nothing Then
    For Each mySubTag In mySubTags
      myValue = myValue & mySubTag.innerText & vbLf
    Next ' mySubTag
  End If
  ActiveCell.Value = myValue
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
MyXlTokyoNpNewsBodySubExit:
  Set myDoc = Nothing
  Set myHTTP = Nothing
End Sub ' MyXlTokyoNpNewsBody *----*----*    *----*----*    *----*----*    *----*----*

Sub MyXlTokyoNpNewsBttnMyOk(Optional MyDummy As Boolean)
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Rem コマンドボタン[OK]OnAction処理
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  CommandBars("MyXlTokyoNpNews").Controls(1).FaceId = 459
End Sub ' MyXlTokyoNpNewsBttnMyOk *----*----*    *----*----*    *----*----*    *----*----*

Sub MyXlTokyoNpNewsBttnMyCancel(Optional MyDummy As Boolean)
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Rem コマンドボタン[キャンセル]OnAction処理
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  CommandBars("MyXlTokyoNpNews").Controls(1).FaceId = 330
End Sub ' MyXlTokyoNpNewsBttnMyCancel *----*----*    *----*----*    *----*----*    *----*----*

Sub MyXlTokyoNpNewsBttnMyDetail(Optional MyDummy As Boolean)
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Rem [ニュースの本文も取り込む]ボタン処理
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  With CommandBars("MyXlTokyoNpNews").Controls(2)
    If .FaceId = 6963 Then
      .FaceId = 220
      .TooltipText = "ニュースの本文も取り込む。"
    Else
     .FaceId = 6963
     .TooltipText = "ニュースの本文は取り込まない。"
    End If
  End With
End Sub ' MyXlTokyoNpNewsBttnMyDetail *----*----*    *----*----*    *----*----*    *----*----*

Sub MyXlTokyoNpNewsBttnMyLastest(Optional MyDummy As Boolean)
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Rem [ニュースの本文も取り込む]ボタン処理
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  With CommandBars("MyXlTokyoNpNews").Controls(3)
    If .FaceId = 220 Then
      .FaceId = 6963
      .TooltipText = "総て本文を取り込む。"
    Else
     .FaceId = 220
     .TooltipText = "最新刊のみ本文を取り込む。"
    End If
  End With
End Sub ' MyXlTokyoNpNewsBttnMyLastest *----*----*    *----*----*    *----*----*    *----*----*