以前何回かご指導受けたものです。

Internet Explorerのサポートが終了する為

Microsoft Edgeに切り替えたら


実行エラー　’-2147467259(80004005)'

'Busy'メソッドは失敗しました；IWebBrowser2'オブジェクト

エラーメッセージが出ます。

エラー箇所

 '表示完了を待つ
    While objIE.ReadyState <> 4

�@ここで停止ーーー＞While objIE.Busy = True

        DoEvents  '特に何もしないで.Busyの状態が変わるまで待つ
      Wend
    Wend

�@ここで停止しています”While objIE.Busy = True　”

=====================＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝

ヤフー競馬の月ごとの競争成績のアドレス取得のマクロです。

シート３のA2行目から取得するようになってます。

上の�@の所で起動停止になります。

ご教授よろしくお願いいたします。

ーーーーヤフー競馬の競争成績アドレス読み込みマクローーー

Sub アドレス読み込み()
　Dim strURL       As String  '入力値を受け取る変数
  Dim objIE        As Object  'ＩＥオブジェクト参照用
  Dim objLINK      As Object  'リンクのオブジェクト受け取り用
  Dim lngLinkCount As Long
  Dim v            As Variant
  Dim vntYYYYMM1   As Variant
  Dim vntYYYYMM2   As Variant
  Dim t            As Single
  Dim strYYYYMMDD  As String '★
  
  'With Worksheets("Sheet3").Range("A1").CurrentRegion '★
    '.Resize(.Rows.Count - 1, 2).Offset(1).Clear '★
    '.Worksheet.Select '★
 'End With '★
 With Worksheets("Sheet3").Range("A1").CurrentRegion '★
    If .Rows.Count > 1 Then '◆
      .Resize(.Rows.Count - 1, 2).Offset(1).Clear '★
    End If '◆
    .Worksheet.Select '★
  End With '★
  
  vntYYYYMM1 = Application.InputBox("取得開始年月を入力してください", , Format(Date, "yyyy/01"))
  If VarType(vntYYYYMM1) = vbBoolean Then
    MsgBox "キャンセルしました"
    Exit Sub
  End If
  If Not IsDate(vntYYYYMM1) Then
    MsgBox "開始年月が日付ではありません [ " & vntYYYYMM1 & " ]"
    Exit Sub
  End If
  
  vntYYYYMM2 = Application.InputBox("取得終了年月を入力してください", , Format(Date, "yyyy/mm"))
  If VarType(vntYYYYMM2) = vbBoolean Then
    MsgBox "キャンセルしました"
    Exit Sub
  End If
  If Not IsDate(vntYYYYMM2) Then
    MsgBox "終了年月が日付ではありません [ " & vntYYYYMM2 & " ]"
    Exit Sub
  End If
    
  t = Timer
  'IEを起動する
  Set objIE = CreateObject("InternetExplorer.application") 'IEのオブジェクトを作る
  objIE.Visible = True '見えるようにする(お約束)
  
  lngLinkCount = 0
  ReDim vntRacelist(lngLinkCount) As String
  
  Do While vntYYYYMM1 <= vntYYYYMM2
    Application.StatusBar = Format(CDate(vntYYYYMM1 & "/01"), "yyyy年mm月") & "の開催情報を取得しています"
    
    strURL = "htt p://keiba.yahoo.co.jp/schedule/" & vntYYYYMM1
    strURL = "htt p://keiba.yahoo.co.jp/schedule/list/" & Left(vntYYYYMM1, 4) & "/?month=" & Val(Right(vntYYYYMM1, 2))
    
    '.Navigate で 指定したURLを開く
    objIE.Navigate strURL
    
    '表示完了を待つ
    While objIE.ReadyState <> 4　’”＜−−ここで停止”
      While objIE.Busy = True
        DoEvents  '特に何もしないで.Busyの状態が変わるまで待つ
      Wend
    Wend
      
    For Each objLINK In objIE.Document.Links
'      If objLINK.Href Like "*racelist*" Then
      If objLINK.Href Like "*race/list*" Then
        ReDim Preserve vntRacelist(lngLinkCount) As String
        vntRacelist(lngLinkCount) = objLINK.Href
        lngLinkCount = lngLinkCount + 1
      End If
    Next
    If vntYYYYMM1 = Format(Date, "yyyy/mm") Then Exit Do
    vntYYYYMM1 = Format(DateAdd("m", 1, CDate(vntYYYYMM1 & "/01")), "yyyy/mm")
  Loop
    
  '1開催は、最大12レース
'  ReDim vntResult(1 To lngLinkCount * 12, 1 To 1) As String '☆
  ReDim vntResult(1 To lngLinkCount * 12, 1 To 2) As String '★
  
  lngLinkCount = 1
  For Each v In vntRacelist
'    strURL = Left(Right(v, 27), 13) '☆
'    strURL = Mid(strURL, 1, 4) & "年" & Val(Mid(strURL, 9, 2)) & "回" & _ '☆
'      Choose(Val(Mid(strURL, 6, 2)), "札幌", "函館", "福島", "新潟", "東京", "中山", "中京", "京都", "阪神", "小倉") & _ '☆
'        Val(Mid(strURL, 12, 2)) & "日" '☆
    strURL = Left(Right(v, 9), 8) '★
    If Mid(strURL, 1, 2) <= "87" Then '★
      strURL = "20" & strURL '★
    Else '★
      strURL = "19" & strURL '★
    End If '★
    strURL = Mid(strURL, 1, 4) & "年" & Val(Mid(strURL, 7, 2)) & "回" & _
      Choose(Val(Mid(strURL, 5, 2)), "札幌", "函館", "福島", "新潟", "東京", "中山", "中京", "京都", "阪神", "小倉") & _
        Val(Mid(strURL, 9, 2)) & "日" '★
    Application.StatusBar = strURL & "のレース情報を取得しています"
    
    strURL = v
    
    '.Navigate で 指定したURLを開く
    objIE.Navigate strURL
    
    '表示完了を待つ
    While objIE.ReadyState <> 4
      While objIE.Busy = True
        DoEvents  '特に何もしないで.Busyの状態が変わるまで待つ
      Wend
    Wend
      
    '開催年月日の取得
    strYYYYMMDD = Split(objIE.Document.getElementsByTagName("div")("cornerTit").innerText, "[")(0) '★
    
    For Each objLINK In objIE.Document.Links
      If objLINK.Href Like "*/result*" Then
        vntResult(lngLinkCount, 1) = objLINK.Href
        vntResult(lngLinkCount, 2) = strYYYYMMDD '★
        lngLinkCount = lngLinkCount + 1
      End If
    Next
  Next
  
'  Range("A2").Resize(lngLinkCount).Value = vntResult '☆
  Range("A2").Resize(lngLinkCount - 1, 2).Value = vntResult '★
  
'  For Each v In vntResult '☆
'    Debug.Print v '☆
'  Next '☆
  
  Application.StatusBar = False
  objIE.Quit   '.Quitで閉じる
  Set objIE = Nothing
  
  MsgBox "URLの取得処理が完了しました  " & Timer - t & "秒", vbInformation

End Sub


この記事にはVBAのコードが含まれています。

緑の太文字→注釈
茶色の太文字→条件分岐
赤の太文字→ループ
青の太文字→その他