Vídeo recomendado
https://youtu.be/diWPPPhW-9E

Application.OnTime desregulado

Fórum para dúvidas sobre os fundamentos da linguagem de programação Visual Basic no contexto do VBA
paulo_goi
Acabou de chegar
Acabou de chegar
Mensagens: 4
Registrado em: Dom Jan 10, 2021 4:54 pm

Application.OnTime desregulado

Mensagem por paulo_goi »

Olá boa noite,

Estou aprendendo VBA e estou tendo um problema com um script que fiz. Periodicamente ele deve coletar dados de um site via selenium e salvar em uma planilha.
De acordo com a rotina criada, de 5 em 5 minutos o Excel deveria rodar o script e apresentar os dados. Durante um tempo isso ocorre corretamente(umas 3 horas mais ou menos), porem percebo que (por algo que eu ainda não sei o que é) esse tempo começa a ficar menor, de 5 para 4 minutos, depois 2 até que fica em loop infinito. Não sei o que pode ser, já pesquisei muito e até em sites gringos e não achei resposta para isso, minha ultima tentativa vai ser aqui que eu acho a comunidade mais fera em VBA da internet brasileira.

Desde já obrigado.


Disable adblock

This site is supported by ads and donations.
If you see this text you are blocking our ads.
Please consider a Donation to support the site.


Avatar do usuário
webmaster
Administrador
Mensagens: 3114
Registrado em: Sex Jul 24, 2009 2:44 pm
Contato:

Re: Application.OnTime desregulado

Mensagem por webmaster »

Código, please?


paulo_goi
Acabou de chegar
Acabou de chegar
Mensagens: 4
Registrado em: Dom Jan 10, 2021 4:54 pm

Re: Application.OnTime desregulado

Mensagem por paulo_goi »

Dim driver As New ChromeDriver


Public Sub Novoscrap()

Dim ck As New By
Dim w As Worksheet
Dim r As Range
Dim m As Worksheet
Dim linkSemEscanteio As Variant
Dim celulaApagar As Integer

Application.EnableCancelKey = xlDisabled

Application.OnTime Now + TimeValue("00:05:00"), "validaHora"


If PlanEstats.Range("A2") <> "" Then
PlanEstats.Select
PlanEstats.Rows("2:110").Select
Selection.Delete Shift:=xlUp
End If

Set m = Sheets("Links")
m.Select
m.Range("A2").Select
If ActiveCell.Value = "" Then

MsgBox "Sem link valida na celula A2 da Aba Jogos de Hoje."

Exit Sub

End If

Set driver = New ChromeDriver
driver.AddArgument ("--headless")

Do While ActiveCell.Value <> ""

driver.Get (ActiveCell.Value)

On Error Resume Next

If driver.IsElementPresent(ck.XPath("/html/body/div/div/div/div[3]/div[2]/div[2]/div[2]/div[2]/div[1]/span/span[1]"), 0) And driver.IsElementPresent(ck.XPath("/html/body/div/div/div/div[3]/div[4]/span/div/div[1]/div[4]/div[2]/div[2]/span"), 0) Then

Set TDados = Sheets("Coleta dados").ListObjects("Tbextrai")
Set novodado = TDados.ListRows.Add

novodado.Range(1, 1).Value = driver.FindElementByXPath("//*[@id=""app""]/div[3]/div[4]/span/div/div[3]/div[2]/div[1]/div[2]/div[1]/span", 0).Text
novodado.Range(1, 2).Value = driver.FindElementByXPath("//*[@id=""app""]/div[3]/div[4]/span/div/div[3]/div[2]/div[1]/div[2]/div[2]/span", 0).Text
novodado.Range(1, 3).Value = driver.FindElementByXPath("/html/body/div/div/div/div[3]/div[2]/div[2]/div[2]/div[1]", 0).Text
novodado.Range(1, 4).Value = driver.FindElementByXPath("/html/body/div/div/div/div[3]/div[2]/div[2]/div[2]/div[3]", 0).Text
novodado.Range(1, 5).Value = driver.FindElementByXPath("/html/body/div/div/div/div[3]/div[4]/span/div/div[3]/div[2]/div[1]/div[3]/div[2]/div[1]/span[1]", 0).Text
novodado.Range(1, 6).Value = driver.FindElementByXPath("/html/body/div/div/div/div[3]/div[4]/span/div/div[3]/div[2]/div[1]/div[3]/div[2]/div[1]/span[3]", 0).Text
novodado.Range(1, 7).Value = driver.FindElementByXPath("/html/body/div/div/div/div[3]/div[4]/span/div/div[3]/div[2]/div[1]/div[3]/div[3]/div[1]/span[1]", 0).Text
novodado.Range(1, 8).Value = driver.FindElementByXPath("/html/body/div/div/div/div[3]/div[4]/span/div/div[3]/div[2]/div[1]/div[3]/div[3]/div[1]/span[3]", 0).Text
novodado.Range(1, 9).Value = driver.FindElementByXPath("/html/body/div/div/div/div[3]/div[4]/span/div/div[3]/div[2]/div[1]/div[3]/div[1]/div[1]/span[1]", 0).Text
novodado.Range(1, 10).Value = driver.FindElementByXPath("html/body/div/div/div/div[3]/div[4]/span/div/div[3]/div[2]/div[1]/div[3]/div[1]/div[1]/span[3]", 0).Text
novodado.Range(1, 11).Value = driver.FindElementByXPath("/html/body/div/div/div/div[3]/div[4]/span/div/div[3]/div[2]/div[1]/div[3]/div[7]/div[1]/span[1]", 0).Text
novodado.Range(1, 12).Value = driver.FindElementByXPath("/html/body/div/div/div/div[3]/div[4]/span/div/div[3]/div[2]/div[1]/div[3]/div[7]/div[1]/span[3]", 0).Text
novodado.Range(1, 13).Value = driver.FindElementByXPath("/html/body/div/div/div/div[3]/div[4]/span/div/div[3]/div[2]/div[1]/div[3]/div[5]/div[1]/span[1]", 0).Text
novodado.Range(1, 14).Value = driver.FindElementByXPath("/html/body/div/div/div/div[3]/div[4]/span/div/div[3]/div[2]/div[1]/div[3]/div[5]/div[1]/span[3]", 0).Text
novodado.Range(1, 15).Value = driver.FindElementByXPath("/html/body/div/div/div/div[3]/div[4]/span/div/div[3]/div[2]/div[1]/div[3]/div[8]/div[1]/span[1]", 0).Text
novodado.Range(1, 16).Value = driver.FindElementByXPath("/html/body/div/div/div/div[3]/div[4]/span/div/div[3]/div[2]/div[1]/div[3]/div[8]/div[1]/span[3]", 0).Text
novodado.Range(1, 17).Value = driver.FindElementByXPath("/html/body/div/div/div/div[3]/div[4]/span/div/div[3]/div[2]/div[1]/div[3]/div[9]/div[1]/span[1]", 0).Text
novodado.Range(1, 18).Value = driver.FindElementByXPath("/html/body/div/div/div/div[3]/div[4]/span/div/div[3]/div[2]/div[1]/div[3]/div[9]/div[1]/span[3]", 0).Text
novodado.Range(1, 19).Value = driver.FindElementByXPath("/html/body/div/div/div/div[3]/div[2]/div[2]/div[2]/div[2]/div[1]/span/span[1]", 0).Text

ActiveCell.Offset(1, 0).Select

Else

Planilha3.Select

If Range("F23").Value <> "" Then

Set r = ActiveCell.Rows

Range("F23").Select

ActiveCell.Copy

r.Select

ActiveCell.PasteSpecial

Rows("23:23").Delete

Else

Set TDados = Sheets("Coleta dados").ListObjects("Tbextrai")
Set novodado = TDados.ListRows.Add
novodado.Range(1, 1) = "Trocar Link"
novodado.Range(1, 2) = "Trocar Link"
ActiveCell.Offset(1, 0).Select

End If

End If

Loop1:

Loop

driver.Quit

End Sub


paulo_goi
Acabou de chegar
Acabou de chegar
Mensagens: 4
Registrado em: Dom Jan 10, 2021 4:54 pm

Re: Application.OnTime desregulado

Mensagem por paulo_goi »

Public Sub validaHora()

Dim w As Worksheet
Dim inicio As Date
Dim fim As Date
Dim r As Integer
Dim ultcell As Range
Dim m As Worksheet
Dim x As Long
Dim prefixo As String
Dim linha As Range
Dim celulaApagar As Variant
Dim linkSemEscanteio As Variant
Dim checkLink As Boolean
Dim procuraLink As Range

Set m = Sheets("Links")
Set w = Sheets("Links com Hora")

m.Select

If Range("F23") = "" Then

Range("F23") = "Jogo ficticio"
Range("F24") = "Jogo ficticio"

End If

w.Select
Range("B2").Select

Do While ActiveCell.Value <> ""

inicio = ActiveCell.Value

If inicio < Time() Then

ActiveCell.Offset(0, -1).Select

Range(Selection, Selection.End(xlToRight)).Select

Selection.Copy

ActiveCell.Offset(0, 1).Select

m.Select

Range("F23").Select
Set linha = Range("F23").End(xlDown)
linha.Select
ActiveCell.Offset(1, 0).Select
ActiveCell.PasteSpecial
w.Select
r = ActiveCell.Row
Rows(r).Select
Selection.Delete Shift:=xlUp
ActiveCell.Offset(0, 1).Select

Else

ActiveCell.Offset(1, 0).Select

End If

Loop

m.Select

Rows("23:24").Select

Selection.Delete

Range("h23").Select

Do While ActiveCell.Value <> ""

fim = ActiveCell.Value

If fim > Time() Then

ActiveCell.Offset(1, 0).Select

Else

r = ActiveCell.Row

Rows(r).Select

Selection.Delete Shift:=xlUp

ActiveCell.Select

ActiveCell.Offset(0, 7).Select

End If

Loop

Columns("G:H").Select

Selection.Delete Shift:=xlUp


If Range("A22") <> "" Then

End If

Call Novoscrap

End Sub


Disable adblock

This site is supported by ads and donations.
If you see this text you are blocking our ads.
Please consider a Donation to support the site.


paulo_goi
Acabou de chegar
Acabou de chegar
Mensagens: 4
Registrado em: Dom Jan 10, 2021 4:54 pm

Re: Application.OnTime desregulado

Mensagem por paulo_goi »

Desde já muito obrigado pela ajuda e desculpe se o código estiver fora do padrão pois estou aprendendo aos poucos com funciona cada função do vba.


Disable adblock

This site is supported by ads and donations.
If you see this text you are blocking our ads.
Please consider a Donation to support the site.


Responder