excel - 堆栈空间不足

Question

我一直在努力解决这个问题。我的堆栈显示：

VBAProject.RecebeContratos.ParseHTML3
[<The code isnt Basic>]
VBAProject.Módulo1.TodosContratosOrgao5
[<The code isnt Basic>] '(I don't know the exact translation for this, my excel is in portuguese)

然后它再次循环

Sub TodosContratosOrgao5(MacroLoop As Long, Z As Long)
    Dim URL As String
    Dim ultimo As Long
    Dim ultimoorgao As Long
    Set rng = Range("D2:D589")
    If MacroLoop = 0 Or MacroLoop = 1 Then
        MacroLoop = 3
    End If
    Do While MacroLoop <= 589
        If Plan4.Range("E1") = Plan5.Range("E" & MacroLoop) Then
            URL = Plan5.Range("C" & MacroLoop).Value
            Call ParseHTML3(URL, MacroLoop, Z, "") 'Here it stops with the stack error
        End If
        MacroLoop = MacroLoop + 1
    Loop
End Sub

有什么想法吗？我不知道如何阻止这些循环堆积。

谢谢你们！

Function ParseHTML3(URL As String, MacroLoop As Long, Z As Long, Teste As String)

    Dim htm As Object: Set htm = CreateObject("htmlfile")
    Dim tr As Object
    Dim td As Object
    Dim X As Long
    Dim i As Long
    Dim URL2 As Long
    Dim htmlColl As MSHTML.IHTMLElementCollection
    Dim htmlElem As MSHTML.IHTMLElementCollection
    Application.DisplayStatusBar = True
    Application.StatusBar = "Recebendo Contratos... Aguarde!"
    Dim shellWins As ShellWindows
    Dim IE As InternetExplorer
    Range("D1").Calculate
    Range("E1").Calculate
    Set shellWins = New ShellWindows

                            'Create IE
    Set IE = New InternetExplorer
    On Error Resume Next
    IE.Visible = True
    On Error GoTo 0
    If Teste = "" Then
        If URL = Plan4.Range("C1").Value Then
            GoTo Termina
        End If
    End If
    IE.Navigate URL
    'Aguarda IE completar o carregamento
    While IE.Busy Or IE.ReadyState <> READYSTATE_COMPLETE
        DoEvents
    Wend


    ''''''''''''''''''''''''''''''''''Clica em "Pesquisar"

    Set htmlColl = IE.Document.getElementsByTagName("input")

    For Each Htmlinput In htmlColl

        If Trim(Htmlinput.Type) = "submit" Then
            Htmlinput.Click
            Do While IE.Busy Or IE.ReadyState <> READYSTATE_COMPLETE
                DoEvents
            Loop
            Exit For
        End If
    Next Htmlinput


    ''''''''''''''''''''''''''''''''''''''''''''''''''''''

        ''''''''''''''''''''''''''''''''' Exibe 100 resultados

    Set htmlColl = IE.Document.getElementsByTagName("select")

    Application.Wait Now + TimeValue("00:00:02")
    For Each HTMLSelect In htmlColl

        Application.Wait Now + TimeValue("00:00:01")

        If Trim(HTMLSelect.Value) = "20" Or Trim(HTMLSelect.Value) = "50" Then
            HTMLSelect.Value = "100"
            HTMLSelect.onchange

            Exit For
        End If
    Next HTMLSelect
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''



''''''''''''''''''''''''''''''''''''''''''Pega o conteúdo da primeira página

    If Teste = "primeira" Then
        Z = 2
        Teste = "segunda"
    End If


    Application.Wait Now + TimeValue("00:00:02")
    With IE.Document.getElementsByTagName("tbody")(1)


        For Each tr In .Rows
        Dim newURL As String
        Dim newURL2 As String
        If tr.innerText <> "Nenhum resultado para esta consulta " Then
            newURL = Mid(tr.innerHTML, InStr(1, tr.innerHTML, ";") + 1, InStr(1, tr.innerHTML, "&amp;idContrato") - 1 - InStr(1, tr.innerHTML, ";"))
            newURL2 = Mid(tr.innerHTML, InStr(1, tr.innerHTML, "idContrato"), InStr(1, tr.innerHTML, "><u") - 2 - InStr(1, tr.innerHTML, ";idContrato"))
            newURL = "http://www3.transparencia.gov.br/TransparenciaPublica/jsp/contratos/contratoExtrato.jsf?consulta=3&" & newURL & "&" & newURL2
        End If
            For Each td In tr.Cells
                X = X + 1
                With Plan6.Range("a" & Z)
                    If X = 1 Then
                        Plan6.Cells(Z, X).Value = td.innerText
                    Else
                        If Left(td.innerText, 2) = " =" Then
                            Plan6.Cells(Z, X).Value = "..." & td.innerText
                        Else
                            Plan6.Cells(Z, X).Value = td.innerText
                        End If
                    End If
                End With
            Next td
        Plan6.Cells(Z, 7).Value = newURL
        Z = Z + 1
        X = 0
        Next tr
    End With

    If i = 0 Then
        i = 134     'Variável referente a páginas
    End If
    w = 136     'Variável referente ao orgão com mais de 10 paginas
    Do
        On Error Resume Next
        Teste = IE.Document.Links(135).innerText
        Teste2 = IE.Document.Links(134).innerText
        On Error GoTo 0
        If Teste2 = "[anterior]" Then
            If w = 146 Then         'Volta a contagem após clicar em [posterior]
                w = 136
            End If
            On Error GoTo Termina
            IE.Document.Links(w).Click
            On Error GoTo 0
            u = 1
            w = w + 1
            On Error GoTo 0

        ElseIf Teste = "[anterior]" Then
            If w = 146 Then         'Volta a contagem após clicar em [posterior]
                w = 135

            End If

        ElseIf Teste2 <> "[anterior]" And Teste = "[anterior]" Then     'Avança página
            IE.Document.Links(i).Click

        ElseIf Teste <> "[anterior]" And Teste2 = "[anterior]" And u <> 1 Then     'Avança página
                IE.Document.Links(i).Click
                u = 0

        ElseIf u <> i Then
            On Error GoTo Termina
                IE.Document.Links(i).Click
            On Error GoTo 0
                u = i

        Else
            IE.Document.Links(w).Click

        End If

        Do While IE.Busy Or IE.ReadyState <> READYSTATE_COMPLETE
            DoEvents
        Loop

    '''''''''''''''''''''''''''''Pega o conteúdo das demais páginas

    On Error GoTo Termina ''''''''''''Finaliza caso não tenha (mais) páginas.

    With IE.Document.getElementsByTagName("tbody")(1)

        For Each tr In .Rows
            newURL = "http://www3.transparencia.gov.br/TransparenciaPublica/jsp/contratos/contratoExtrato.jsf?consulta=3&" & Mid(tr.innerHTML, InStr(1, tr.innerHTML, ";") + 1, InStr(1, tr.innerHTML, "&amp;idContrato") - 1 - InStr(1, tr.innerHTML, ";")) & "&" & Mid(tr.innerHTML, InStr(1, tr.innerHTML, "idContrato"), InStr(1, tr.innerHTML, "><u") - 2 - InStr(1, tr.innerHTML, ";idContrato"))
                For Each td In tr.Cells
                    X = X + 1
                    With Plan6.Range("a" & Z)
                        If X = 1 Then
                        Plan6.Cells(Z, X).Value = td.innerText
                    Else
                        If Left(td.innerText, 2) = " =" Or Left(td.innerText, 1) = "=" Then
                            Plan6.Cells(Z, X).Value = "..." & td.innerText
                        Else
                            Plan6.Cells(Z, X).Value = td.innerText
                        End If
                    End If
                    End With
                Next td
            Plan6.Cells(Z, 7).Value = newURL
            Z = Z + 1
            X = 0
        Next tr
    i = i + 1
    End With
    Loop


''''''''''''''''''''''''''''''''''''''''''''''''''''''



Termina:
    IE.Quit
    If MacroLoop <> 0 Then
        MacroLoop = MacroLoop + 1
    End If
    i = 0
    Call TodosContratosOrgao5(MacroLoop, Z)
    Application.StatusBar = "Pronto."
    Exit Function

End Function



End Sub

很抱歉没有发布 de PasteHTML3 代码，在这里。（它运行良好，但一段时间后停止！）

我的工作表上有一个按钮，可以在 ParseHTML 之前运行宏：

Sub GetData()
    Dim Teste As String
    Plan6.UsedRange.ClearContents
    Range("D1").Calculate
    Range("E1").Calculate
    Range("C1").Calculate
    Teste = "primeira"
    Call ParseHTML3(Plan4.Range("C1").Value, 0, 0, Teste)

End Sub

score 1 · Accepted Answer

您的 ErrorHandler ( Termina) 似乎是堆栈溢出的情况：

您首先调用 (1) ParseHTML3。如果出现问题，代码执行将在Termina调用 (2)TodosContratosOrgao5时继续MacroLoop+1。

然后在TodosContratosOrgao5你从 MacroLoop 循环到 589，调用 (3) ParseHTML3。假设第一次运行时发生的相同错误仍然存在，ParseHTML3实际上将TodosContratosOrgao5再次调用 (4)，依此类推！因此，您的堆栈将继续增长，如下所示：

解析HTML3
TodosContratosOrgao5
解析HTML3
TodosContratosOrgao5
...

您可能想要做的是首先调用TodosContratosOrgao5（使用正确的 MacroLoop 值） - 如果ParseHTML3导致错误，只需退出函数 - 然后TodosContratosOrgao5调用下一行！

另外，尝试在中查找错误，使用!ParseHTML3逐步执行代码F8

score 1 · Accepted Answer

堆栈空间不足意味着您的程序中有太多嵌套调用。这通常是由循环引用引起的。

在这种情况下， in ParseHTML3you callTodosContratosOrgao5和 in TodosContratosOrgao5you call ParseHTML3。这永远不会解决，而是他们会一次又一次地打电话给对方。

这个问题的一个更简单的例子是：

Sub DoFoo()
     Call DoBar
End Sub

Sub DoBar()
    Call DoFoo
End Sub

excel - 堆栈空间不足

2 回答 2

Related

Reference