'Microsoft HTML Object Libraryが必要

Sub GET_last_modified()
'Google Chromeを起動
'CreateObject("WScript.Shell").Run ("chrome.exe")

Dim objIE As Object
Dim html As String
Dim 行末 As Long
Dim h


Dim Rtn
Rtn = MsgBox(Chr(10) & "読み込み 実行", vbYesNo, "選択")
If Rtn = vbYes Then
'Application.ScreenUpdating = False
'================================
Dim myBook, mySheet
myBook = ActiveWorkbook.Name
mySheet = ActiveSheet.Name



Worksheets(mySheet).Select
Worksheets(mySheet).Activate
i = 2
行末 = Worksheets(mySheet).Cells(Rows.Count, 2).End(xlUp).Row

Set h = CreateObject("MSXML2.XMLHTTP")

Set objIE = CreateObject("InternetExplorer.application")
'Set objIE = CreateObject("WScript.Shell").Run("chrome.exe")

Set WSH = CreateObject("WScript.Shell")

'Set WSH = CreateObject("WScript.Shell").Run("chrome.exe")


Do

If Len(Worksheets(mySheet).Range("c" & i).Value) < 1 Then


If Len(Worksheets(mySheet).Range("b" & i).Value) < 5 Then
Exit Do
End If

'Do While objIE.Busy Or objIE.ReadyState <> 4
DoEvents
'Loop


 h.Open "HEAD", Worksheets(mySheet).Range("b" & i).Value, False
Worksheets(mySheet).Range("C" & i).Select
    
    h.send
    Dim headers
    headers = h.getAllResponseHeaders()
    
    If InStr(headers, "Last-Modified") > 0 Then
        Worksheets(mySheet).Range("C" & i).Value = h.getResponseHeader("Last-Modified") '通信回数を減らしたい場合はheadersをSplitしてください
    Else
        If InStr(headers, "last-modified") > 0 Then
            Worksheets(mySheet).Range("C" & i).Value = h.getResponseHeader("last-modified") '通信回数を減らしたい場合はheadersをSplitしてください
        ElseIf InStr(headers, "date") > 0 Then
            Worksheets(mySheet).Range("C" & i).Value = h.getResponseHeader("date") '通信回数を減らしたい場合はheadersをSplitしてください
        
        Else
            Worksheets(mySheet).Range("C" & i).Value = "Last-Modifiedが見つかりません"
        End If
    End If


End If
'End If
flg = ""

i = i + 1
状況 = Int(i / 行末 * 100)
未完 = 100 - 状況
If 状況 > 0 And 未完 > 0 Then
Application.StatusBar = "(" & i & "/" & 行末 & "行目を処理中…)"
End If
If i > 行末 Then

'Exit Do

End If
Loop
Application.StatusBar = False
Application.StatusBar = ""

'================================
'  Application.ScreenUpdating = True
    MsgBox "取り込みが完了しました"
    
    
End If 'If Rtn = vbYes Then
'  Application.ScreenUpdating = True



End Sub

Sub サイト確認マクロall()
'Google Chromeを起動
'CreateObject("WScript.Shell").Run ("chrome.exe")

Dim objIE As Object
Dim html As String
Dim 行末 As Long
Dim h



Dim Rtn
Rtn = MsgBox(Chr(10) & "読み込み 実行", vbYesNo, "選択")
If Rtn = vbYes Then

Dim myBook, mySheet
myBook = ActiveWorkbook.Name
mySheet = ActiveSheet.Name


'Application.ScreenUpdating = False
'================================

Worksheets(mySheet).Select
Worksheets(mySheet).Activate



i = 2
行末 = Worksheets(mySheet).Cells(Rows.Count, 2).End(xlUp).Row

Set h = CreateObject("MSXML2.XMLHTTP")

Set objIE = CreateObject("InternetExplorer.application")
'Set objIE = CreateObject("WScript.Shell").Run("chrome.exe")
Set WSH = CreateObject("WScript.Shell")
'Set WSH = CreateObject("WScript.Shell").Run("chrome.exe")



Do
If Len(Worksheets(mySheet).Range("d" & i).Value) < 1 Then

If Len(Worksheets(mySheet).Range("c" & i).Value) < 5 Then
Exit Do
End If

'Do While objIE.Busy Or objIE.ReadyState <> 4
DoEvents
'Loop


 h.Open "HEAD", Worksheets(mySheet).Range("b" & i).Value, False
Worksheets(mySheet).Range("c" & i).Select
    
    h.send
    Dim headers
    headers = h.getAllResponseHeaders()
  
        Worksheets(mySheet).Range("c" & i).Value = headers '通信回数を減らしたい場合はheadersをSplitしてください
  
End If

'End If
flg = ""

i = i + 1
状況 = Int(i / 行末 * 100)
未完 = 100 - 状況
If 状況 > 0 And 未完 > 0 Then
Application.StatusBar = "(" & i & "/" & 行末 & "行目を処理中…)"
End If
If i > 行末 Then

'Exit Do

End If
Loop
Application.StatusBar = False
Application.StatusBar = ""

'================================
'  Application.ScreenUpdating = True
    MsgBox "取り込みが完了しました"
    
    
End If 'If Rtn = vbYes Then
'  Application.ScreenUpdating = True



End Sub



'■全シートの改行を削除する
Sub call_ReplaceNewLine()
 
    Dim ws As Worksheet
 
    '本来Excelの改行はLfですが、Windowsの改行のvbCrlfも念のため削除
    'Windowsではあまり使わないvbCrも同様に削除。
    For Each ws In ActiveWorkbook.Worksheets
        ws.UsedRange.Replace vbCrLf, ""
        ws.UsedRange.Replace vbLf, ""
        ws.UsedRange.Replace vbCr, ""
    Next ws
 
End Sub