vba 每个元素循环错误发生在第二个循环

问题描述

我是 VBA 新手，正在尝试从网站上抓取数据。我使用了嵌套循环。当最里面的循环第一次完成时，下一个循环开始为 marakez。

实际问题是当'for each in schl2'循环第二次重复时，IE崩溃并且循环无法继续。我在代码中提到过。

这是我的代码

    Sub ResultDownloader()
    
    ' here I define elemnts for the loop
    Dim sht As Worksheet
    Set sht = ThisWorkbook.Sheets("LocData")
    Dim LastRow As Long
    Dim i As Long
    Dim imagePath As Object
                    
    LastRow = sht.Cells(sht.Rows.Count,"D").End(xlUp).Row
    startrec = sht.Cells(sht.Rows.Count,"E").End(xlUp).Row
    startrec = startrec + 1

    Dim IE As Object
    Dim Doc As HTMLDocument
    '        Set IE = CreateObject("InternetExplorer.Application")
    Set IE = CreateObject("InternetExplorer.Application")
    
    ' here I define Object to sendkeys
    Dim SHELL_OBJECT
    SHELL_OBJECT = "WScript.Shell"
    Set objShell = CreateObject(SHELL_OBJECT)
    

    
        Record2Strt = (sht.Cells(sht.Rows.Count,"E").End(xlUp).Row) + 1
IE.Visible = True
IE.Navigate "some_url"

do while IE.Busy
    Application.Wait DateAdd("s",1,Now)
Loop
                    

Dim HTMLdoc As HTMLDocument
Dim selectElement,selectElement2,selectElement3 As HTMLSelectElement
Dim evtChange As Object
Set Doc = IE.Document
Dim dist1,tehsl1,mrkz1,schl1 As Object
Dim dist2,tehsl2,mrkz2,schl2 As Variant
Dim distlen,thsllen,mrkzlen,schllen As Byte
Dim dst,tsl,mrkz,schl As Byte
Dim elt3,elt4,elt5,elt6 As Variant


Set evtChange = Doc.createEvent("HTMLEvents")
evtChange.initEvent "change",True,False


      Set dist1 = Doc.querySelector("Select[name=districts]")
      Set dist2 = dist1.querySelectorAll("option")
      distlen = dist1.querySelectorAll("option").Length
      dst = 0
      For Each elt3 In dist2
       distnme = elt3.innerText
       If distnme <> "All districts" Then
       dist1.getElementsByTagName("option")(dst).Selected = True
       Set selectElement2 = Doc.getElementsByTagName("option")(dst)
       selectElement2.dispatchEvent evtChange
       Application.Wait DateAdd("s",0.5,Now)
       
       
       Set tehsl1 = Doc.querySelector("Select[name=tehsil]")
       Set tehsl2 = tehsl1.querySelectorAll("option")
       thsllen = tehsl1.querySelectorAll("option").Length
       tsl = 0
       For Each elt4 In tehsl2
       thslnme = elt4.innerText
       If thslnme <> "All Tehsils" Then
       Set tehsl1 = Doc.querySelector("Select[name=tehsil]")
       tehsl1.getElementsByTagName("option")(tsl).Selected = True
       Set selectElement3 = tehsl1.getElementsByTagName("option")(tsl)
       selectElement3.dispatchEvent evtChange
       Application.Wait DateAdd("s",Now)
       

       Set mrkz1 = Doc.querySelector("Select[name=markaz]")
       Set mrkz2 = mrkz1.querySelectorAll("option")
       mrkzlen = mrkz1.querySelectorAll("option").Length
       mrkz = 0
       For Each elt5 In mrkz2
       mrkznm = elt5.innerText
       If mrkznm <> "All Marakez" Then
       Set mrkz1 = Doc.querySelector("Select[name=markaz]")
       mrkz1.getElementsByTagName("option")(mrkz).Selected = True
       Set selectElement4 = mrkz1.getElementsByTagName("option")(mrkz)
       selectElement4.dispatchEvent evtChange
       Application.Wait DateAdd("s",Now)
       
           Set schl1 = Doc.querySelector("Select[name=school]")
           Set schl2 = schl1.querySelectorAll("option")
           schllen = schl1.querySelectorAll("option").Length
           schl = 0
    '               second loop problem
    '               when for each elt6 in schl2 starts IE crashes

           On Error Resume Next
           For Each elt6 In schl2
           Application.Wait DateAdd("s",Now)
           schlnm = elt6.innerText
           If schlnm <> "All Schools" Then
           Set schl1 = Doc.querySelector("Select[name=school]")
           schl1.getElementsByTagName("option")(schl).Selected = True
           Set selectElement5 = schl1.getElementsByTagName("option")(schl)
           selectElement5.dispatchEvent evtChange

               sht.Range("A" & LastRow + 1).Value = LastRow
               sht.Range("B" & LastRow + 1).Value = distnme
               sht.Range("C" & LastRow + 1).Value = thslnme
               sht.Range("D" & LastRow + 1).Value = mrkznm
               sht.Range("E" & LastRow + 1).Value = schlnm
               LastRow = LastRow + 1
           End If       'for school

           
           schl = schl + 1
           If schllen = schl Then
           GoTo new_marakez
           On Error Resume Next
           End If
           Next         'ele6

       End If       'for marakez
new_marakez:
       mrkz = mrkz + 1
       If mrkzlen = mrkz Then
       Exit For
       GoTo new_tehsil
       End If
       
       Next         'ele5
       On Error Resume Next
       End If       'for tehsils
new_tehsil:
       tsl = tsl + 1
       If thsllen = tsl Then
       GoTo new_dist
       End If
       
       Next         'ele4
       On Error Resume Next
       End If       'for districts
new_dist:
        dst = dst + 1
       If distlen = dst Then
       GoTo stopp
       End If
       
       Next         'ele 3
       On Error Resume Next
       
  

stopp:
End Sub

解决方法

暂无找到可以解决该程序问题的有效方法，小编努力寻找整理中！

如果你已经找到好的解决方法，欢迎将解决方案带上本链接一起发送给小编。

小编邮箱:dio#foxmail.com (将#修改为@）