サンプルVBA

Sub ScrapeWithShiftJIS()
    Dim xmlhttp As Object
    Dim url As String
    Dim userAgentPC As String
    Dim userAgentSP As String
    Dim html As String
    Dim binaryData() As Byte
    Dim stream As Object
    Dim doc As Object
    Dim pageTitle As String
    Dim pageH1 As String
    Dim ws As Worksheet
    Dim rowNum As Integer
    
    ' シートを設定
    Set ws = ThisWorkbook.Sheets("Sheet1")
    rowNum = 1 ' 開始行番号

    ' PC用User-Agentを設定
    userAgentPC = "Mozilla/5.0 (Windows NT 10.0; Win64; x64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/91.0.4472.124 Safari/537.36"
    
    ' スマホ用User-Agentを設定（例: iPhoneのUser-Agent）
    userAgentSP = "Mozilla/5.0 (iPhone; CPU iPhone OS 13_2_3 like Mac OS X) AppleWebKit/605.1.15 (KHTML, like Gecko) Version/13.0.3 Mobile/15E148 Safari/604.1"
    
    ' リクエストするURL
    url = "https://exaple.com"
    
    ' PCとスマホ用User-Agentで繰り返し
    Dim userAgents As Variant
    userAgents = Array(userAgentPC, userAgentSP)
    
    Dim i As Integer
    For i = LBound(userAgents) To UBound(userAgents)
        ' MSXML2.XMLHTTPのオブジェクトを作成
        Set xmlhttp = CreateObject("MSXML2.XMLHTTP")
        
        On Error GoTo ErrorHandler
        
        ' GETリクエストを初期化
        xmlhttp.Open "GET", url, False
        
        ' User-Agentを設定
        xmlhttp.setRequestHeader "User-Agent", userAgents(i)
        
        ' リクエストを送信
        xmlhttp.send
        
        ' レスポンスのステータスをチェック
        If xmlhttp.Status = 200 Then
            ' バイナリデータを取得
            binaryData = xmlhttp.responseBody
            
            ' ADODB.Streamを使用してバイナリデータを文字列に変換
            Set stream = CreateObject("ADODB.Stream")
            With stream
                .Type = 1 ' バイナリデータ
                .Open
                .Write binaryData
                .Position = 0
                .Type = 2 ' テキストデータ
                .Charset = "Shift-JIS"
                html = .ReadText
                .Close
            End With
            
            ' HTMLを解析してタイトルと最初のh1を取得
            Set doc = CreateObject("htmlfile")
            doc.Write html
            
            On Error Resume Next
            pageTitle = doc.getElementsByTagName("title")(0).innerText
            pageH1 = doc.getElementsByTagName("h1")(0).innerText
            On Error GoTo 0
            
            ' 結果をExcelのセルに入力
            ws.Cells(rowNum, 1).Value = "User-Agent " & (i + 1)
            ws.Cells(rowNum, 2).Value = "Title: " & pageTitle
            ws.Cells(rowNum, 3).Value = "H1: " & pageH1
            rowNum = rowNum + 1
        Else
            MsgBox "リクエストに失敗しました。ステータスコード: " & xmlhttp.Status
        End If
        
        ' オブジェクトの解放
        Set xmlhttp = Nothing
        Set stream = Nothing
        Set doc = Nothing
        
        On Error GoTo 0
    Next i
    
    Exit Sub
    
ErrorHandler:
    MsgBox "エラーが発生しました: " & Err.Description
    On Error GoTo 0
End Sub



Sub ReadLocalHTMLFile()
    Dim filePath As String
    Dim htmlDoc As Object
    Dim title As String
    Dim h1 As String
    Dim ws As Worksheet
    Dim rowNum As Integer

    ' シートを設定
    Set ws = ThisWorkbook.Sheets("Sheet1")
    rowNum = 1 ' 開始行番号

    ' HTMLファイルのパスを設定
    filePath = "C:\path\to\your\file.html" ' ここにHTMLファイルのパスを指定

    ' HTMLファイルを読み取る
    Set htmlDoc = CreateObject("HTMLFILE")
    With htmlDoc
        .Open
        .Write GetFileContent(filePath)
        .Close
    End With

    ' タイトルとh1タグの内容を抽出
    On Error Resume Next
    title = htmlDoc.getElementsByTagName("title")(0).innerText
    h1 = htmlDoc.getElementsByTagName("h1")(0).innerText
    On Error GoTo 0

    ' 抽出した内容をExcelに転記
    ws.Cells(rowNum, 1).Value = "Title: " & title
    ws.Cells(rowNum, 2).Value = "H1: " & h1

    MsgBox "処理が完了しました。"

    ' オブジェクトの解放
    Set htmlDoc = Nothing
End Sub

Function GetFileContent(filePath As String) As String
    Dim fileContent As String
    Dim fileNumber As Integer
    Dim tempContent As String
    fileNumber = FreeFile

    On Error GoTo ErrorHandler

    ' ファイルを開いて内容を読み取る
    Open filePath For Input As fileNumber

    Do While Not EOF(fileNumber)
        Line Input #fileNumber, tempContent
        fileContent = fileContent & tempContent & vbCrLf
    Loop

    Close fileNumber

    GetFileContent = fileContent
    Exit Function

ErrorHandler:
    MsgBox "ファイルの読み取り中にエラーが発生しました: " & Err.Description
    Close fileNumber
End Function