スキルアップ・問題解決なら、モーグにおまかせ！

ブログに投稿した数が約1200件あります。この投稿したブログの日付/タイトル/URLを自動で抽出したいのですが適当の方法が有りましたらご教示ねがいます🙇‍♂️⤵️。

こんにちは。
ブログと言っても世の中には色々なブログがあります。
・検索機能はどのようなものが備わっているのですか？
・ブログの記事の構造、URLの体系などどのようなものか？
・あなた自身がどのようなトライをされて、どこに詰まっているのか、等の
説明が必要だと思います。
イントラネットではなく、少なくとも公開されているものであれば、URLを示すことはできますか？

私のブログのURLです。
 
http://query1576.livedoor.blog/
 
宜しくお願い致します。

こちらの規定をご覧になれば、
https://www.moug.net/faq/kiyaku.html#link4
コードの製作依頼は禁止事項に挙げられているようです。
 
なので、まずはご自分でトライされることをお薦めします。
 
もし私が実行するのであれば、概略以下の方針で実行します。

・2012年７月から現在までの年月ごとにページ内容（HTMLテキスト）を取得します。
  年月の指定は簡単に繰り返しに持ち込めると思います。
・取得したHTMLテキストを元に、正規表現を使って、
    ・年月日
    ・タイトル
    ・URL
  を取得します。（１ページに最大5個あります）
・継続記事へのpaging指定
  <a rel="next" href="http://query1576.livedoor.blog/archives/2012-07.html?p=2">
  があれば、そのURLを使って、同じ処理を繰り返します。

有難うございました。
トライして見ます。

トライしてみて下さいとは申し上げたものの、
正規表現とかHTML取得とか慣れがある程度必要かもしれません。
時間が取れたので作成してみました。参考にしてください。
 
■シートの準備
<<Sheet1>> 結果を書きこむシート
 
<<Sheet2>> B列に、以下の要領で、対象アーカイブ年月を作成

  A列         B列
1 2023年03月  2023-03
2 2023年02月  2023-02
3 2022年09月  2022-09
 （以下略)

Option Explicit
Dim re          As Object
Dim re2         As Object
Dim myCount     As Long
Dim mat()       As String

Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Sub main()
    Dim url     As String
    Dim s       As String
    Dim k       As Long
    Dim ws1     As Worksheet
    Dim ws2     As Worksheet
    
    Set ws1 = Worksheets("Sheet1")  '結果書き込みシート                '■要修正
    Set ws2 = Worksheets("Sheet2")  '対象となる年月文字列を書いたシート'■要修正
    Call setRegExp  '正規表現の設定
    myCount = 1     '結果を書き込む動的配列の大きさを初期設定

    '年月別アーカイブを順次処理
    For k = 1 To 2    ' 検証のため一部に限定しています。      '■要修正
    'For k = 1 To ws2.Cells(Rows.Count, "B").End(xlUp).Row    '■OKであればこちら
        s = ws2.Cells(k, "B").Text
        DoEvents
        Application.StatusBar = s
        
        url = "http://query1576.livedoor.blog/archives/" & s & ".html"
        '情報（年月日/URL/タイトル/category1URL/category1)を取得
        Call do_job(url)
    Next
    '結果の配列をシートに書き込む
    ws1.[A1].Resize(UBound(mat, 2), 5) = Application.Transpose(mat)
    Application.StatusBar = False
    MsgBox "処理終了"
    Erase mat
End Sub

Function do_job(url As String)
    Dim html    As String
    Dim m       As Object
    Dim next_url As String

    html = getHtml(url)                 'HTMLテキストを取得
    Sleep 1000                          'サーバーへの負荷を考慮して間隔（1秒）を置く
    
    Call getInformation(html)'情報（年月日/URL/タイトル/category1URL/category1)を取得

    If re2.test(html) Then              '次ページがあれば
        Set m = re2.Execute(html)
        next_url = m(0).submatches(0)   '次ページのURL
        Call do_job(next_url)           '再帰実行
    End If
End Function

Sub setRegExp()
    '-------  情報取得用の正規表現パターン
    Dim pat     As String
    Set re = CreateObject("VBScript.RegExp")
    re.Global = True    '一か所だけでなく、マッチする箇所はすべて

    pat = "<header class=""article\-header"">\s*"
    pat = pat & "<p class=""article\-date""><time datetime="".*?"" itemprop=""datePublished"">(.*?)</time></p>\s*"
    pat = pat & "<h1 class=""article\-title"" itemprop=""name""><a href=""(.*?)"" itemprop=""url"">(.*?)</a></h1>"
    pat = pat & "[\s\S]*?"
    pat = pat & "<dl><dt>カテゴリ:</dt><dd class=""article\-category1""><a href=""(.*?)"">(.*?)</a>"
    re.Pattern = pat

    '------- 「次へ」の取得用の正規表現パターン
    Set re2 = CreateObject("VBScript.RegExp")
    re2.Pattern = "<a rel=""next"" href=""(.*?)"">"
End Sub

'HTMLテキストs から、特定の条件を満たす文字列を取得
Function getInformation(s As String)
    Dim m       As Object
    Dim k       As Long
    Dim j       As Long

    Set m = re.Execute(s)
    For k = 0 To m.Count - 1
        ReDim Preserve mat(1 To 5, 1 To myCount)
        For j = 1 To 5
            mat(j, myCount) = m(k).submatches(j - 1)
        Next
        myCount = myCount + 1
    Next
End Function

Function getHtml(url As String) As String
    Const adTypeBinary = 1
    Const adTypeText = 2
    Dim HttpRequest As Object
    Dim Strm    As Object

    Set HttpRequest = CreateObject("MSXML2.XMLHTTP")
    Set Strm = CreateObject("ADODB.Stream")

    With HttpRequest
        .Open "GET", url, False
        .send
    End With

    With Strm
        .Type = adTypeBinary
        .Open
        .Write HttpRequest.responseBody
        .Position = 0
        .Type = adTypeText
        .Charset = "UTF-8"
        getHtml = .ReadText()
        .Close
    End With
End Function

本当にありがとうございます。暫くは時間が掛かると思いますが結果は報告させて頂きます。

Option Explicit
 
Private Const URL_HOME As String = "http://query1576.livedoor.blog/"
 
Sub Test()
    '========== アーカイブの全URL取得 ==========
    Dim URLArchiveList As Object
    Set URLArchiveList = CreateObject("System.Collections.ArrayList")
     
    Call GetArchiveURL(URLArchiveList)
     
    '========== ブログのデータ取得 ==========
    Dim URL As Variant
    Dim BlogList As Object
    Set BlogList = CreateObject("System.Collections.ArrayList")
     
    For Each URL In URLArchiveList
        Call GetBlogData(URL, BlogList)
    Next
     
    '========== シートにデータ書き込み ==========
    Dim RowIndex As Long
    Dim List As Object
     
    RowIndex = 1
    For Each List In BlogList
        Worksheets("Sheet1").Cells(RowIndex, 1).Value = List(1) '日付
        Worksheets("Sheet1").Cells(RowIndex, 2).Value = List(2) 'タイトル
        Worksheets("Sheet1").Cells(RowIndex, 3).Value = List(3) 'URL
         
        RowIndex = RowIndex + 1
    Next
     
    Set URLArchiveList = Nothing
    Set BlogList = Nothing
 
    Call MsgBox("終了")
End Sub
 
'''ブログのデータ取得
Private Sub GetBlogData(ByVal URL As String, ByRef BlogList As Object)
    Dim XmlHttp As Object 'MSXML2.XMLHTTP
    Dim HtmlDoc As Object 'MSHTML.HTMLDocument
 
    Set XmlHttp = CreateObject("MSXML2.XMLHTTP")
    XmlHttp.Open "GET", URL, False
    XmlHttp.Send
 
    Set HtmlDoc = CreateObject("htmlfile")
    HtmlDoc.body.innerHtml = XmlHttp.responseText
 
    Dim ArticleData As Object
    Set ArticleData = HtmlDoc.getElementsByClassName("article-header")
 
    Dim Data As Object
    Dim DataList As New Collection
 
    For Each Data In ArticleData
        DataList.Add Trim(Data.Children(0).innerText) '日付
        DataList.Add Trim(Data.Children(1).innerText) 'タイトル
        DataList.Add Split(Trim(Data.Children(1).innerHtml), """")(1) 'URL
         
        BlogList.Add DataList
        Set DataList = New Collection
    Next
 
    Set ArticleData = Nothing
    Set HtmlDoc = Nothing
    Set XmlHttp = Nothing
End Sub
 
'''アーカイブの全URL取得
Private Sub GetArchiveURL(ByRef URLArchiveList As Object)
    Dim XmlHttp As Object 'MSXML2.XMLHTTP
    Dim HtmlDoc As Object 'MSHTML.HTMLDocument
 
    Set XmlHttp = CreateObject("MSXML2.XMLHTTP")
    XmlHttp.Open "GET", URL_HOME, False
    XmlHttp.Send
 
    Set HtmlDoc = CreateObject("htmlfile")
    HtmlDoc.body.innerHtml = XmlHttp.responseText
 
    Dim SideBody As Object
    Set SideBody = HtmlDoc.getElementsByClassName("sidebody")
 
    Dim Data As Object
    For Each Data In SideBody
        If Data.ClassName = "sidebody" Then
            URLArchiveList.Add CStr(Data.FirstChild.href)
        End If
    Next
 
    Set Data = Nothing
    Set SideBody = Nothing
    Set HtmlDoc = Nothing
    Set XmlHttp = Nothing
End Sub
 
URLのアーカイブからURLを取得して、取得するようにしました。
ご参考までに。

詠み人知らず　様
 
有難うございます。
図書館で関連図書を沢山借り込み何とか物にしたいと思っています。

私のコードについて訂正です。
正規表現のパターンで、"-"を\でEscape処理していますが、不要でした。
[]の中で-を使うと特別の意味になりますが、-自身が特殊文字ということではないので、
Escape処理は不要でした。（現状のままでも動作はしますが、余計なことでした）
 
ところで、コードを読み取いている最中かもしれませんが、
いったん動作確認部分までを簡単に中間総括してもらえませんか？
 
急かすつもりはないのですが、未解決の状態が長く続くことは、
掲示板の印象が余りよろしくありません。よろしくお願いします。

皆さんから貴重なアイディアを頂きましたので、これを元に検討を加えたいと思います。
完成した暁にはこの場で報告するとして、このアイテムは一先ず終了とさせて頂きます。