我一直在努力解决这个问题。我的堆栈显示：
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, "&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, "&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