dare un tempo ad esecuzione macro

[raimea]

ciao
ho una macro che mi preleva delle partite da un sito.

alcune volte xro il sito e' of.linee o non raggiungibile ,
e tale macro non mi si sblocca piu
non so come fermarla, devo chiudere excel in maniera forzata.

vorrei mettere un timer , ES 240 Sec
dopo il quale se la macro non ha finito esca dal ciclo,
con un mesg di errore, tipo - non risponde.

questa la macro in questione:

Codice: Seleziona tutto

Sub Rettangoloarrotondato2_Click()
Dim r As Long

   If MsgBox("ATTENZIONE!!!:" & vbNewLine & _
                vbNewLine & _
                " QUESTA FUNZIONE AGGIORNA GLI INCONTRI DEL GIORNO     " & vbNewLine & _
                vbNewLine & _
                "LA DATA E' QUELLA GIUSTA?." & vbNewLine & _
                vbNewLine & _
                "SEI PROPRIO SICURO?", _
                vbCritical + vbYesNo + vbDefaultButton2, "Cancellazione CELLA") = vbNo Then
                Exit Sub
                End If
               

UserForm1.Show vbModeless
DoEvents
Nascoste = 0
   
inizio = Timer

Application.ScreenUpdating = False

Sheets("partite").Visible = True  'visualizza
Worksheets("prono").Unprotect

    Sheets("PARTITE").Select
    Range("G4").Select
    With Selection.QueryTable
        .Connection = _
        "URL;http://www.betonews.com/table.asp?tp=2002&lang=en&dd=" & [ab3] & "&dm=" & [ab4] & "&dy=" & [ab5] & "&df=1&dw=3"
        .WebSelectionType = xlSpecifiedTables
        .WebFormatting = xlWebFormattingNone
        .WebTables = "25"
        .WebPreFormattedTextToColumns = False
        .WebConsecutiveDelimitersAsOne = False
        .WebSingleBlockTextImport = False
        .WebDisableDateRecognition = True
        .WebDisableRedirections = True
        .Refresh BackgroundQuery:=False
    End With


Sheets("PARTITE").Select

Range("R3:t10000").ClearContents

ctr = Range("X2") 'cella X2 di fgl partite

Range("G3:G" & ctr).Copy Range("R3")
Range("I3:I" & ctr).Copy Range("S3")
Range("C3:C" & ctr).Copy Range("T3")

r = Sheets("Partite").Cells(Rows.Count, 27).End(xlUp).Row

Columns(27).Select
    Selection.AutoFilter
    ActiveSheet.Range("$AA$1:$AA$" & r).AutoFilter Field:=1, Criteria1:="OK"
    Range("R3").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
   
    Sheets("PRONO").Select
    Range("G7").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
       
    Sheets("PARTITE").Select
    Range("S3").Select
    Range(Selection, Selection.End(xlDown)).Select
    Application.CutCopyMode = False
    Selection.Copy
   
    Sheets("PRONO").Select
    Range("H7").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
   
    Sheets("PARTITE").Select
    Range("T3").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
   
    Sheets("PRONO").Select
    Range("C7").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
       Application.CutCopyMode = False
   
    Sheets("PARTITE").Select
    Range("AA1").Select
    Selection.AutoFilter
   
    Sheets("partite").Visible = False

 
Sheets("PRONO").Select
Application.Calculation = xlCalculationAutomatic

Call aggiorno_quote ' aggiorno tutte lequote

Range("V4") = Range("Z2")

'----nascondo righe con campion diversi-------------

'DISATTIVO LE APPLICATION PER VELOCIZZARE
'L'ESECUZIONE DELLA MACRO

Dim xlCal As XlCalculation
With Application
    .ScreenUpdating = False
    .EnableEvents = False
    xlCal = .Calculation
    .Calculation = xlCalculationManual
End With
'-----------------

For I = Range("e" & Rows.Count).End(xlUp).Row To 7 Step -1

    If Cells(I, 5) <> Cells(I, 10) Then  '5=E  10=j
        Rows(I).Hidden = True
    Nascoste = Nascoste + 1
    End If
Next
'-------------------------------------------------------
'RIATTIVO LE APPLICATION
With Application
    .Calculation = xlCal
    .EnableEvents = True
    .ScreenUpdating = True
End With

'-------------------------------------------------------
   
    ActiveWindow.DisplayGridlines = False
    ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True _
        , AllowFormattingColumns:=True, AllowFormattingRows:=True

Unload UserForm1

Cells(7, 3).Select

MsgBox "Sono state nascoste  " & Nascoste & "  righe"

fine = Timer

MsgBox ("Tempo impiegato " & Int((fine - inizio) / 60) & " min " & (fine - inizio) Mod 60 & " Sec")



End Sub

ciao

[Flash30005]

Non ho approfondito il funzionamento della macro
ma penso che non trovando nulla nella pagina dei dati da queryweb la routine entri in loop
se così, puoi inserire una riga codice di controllo con la condizione di uscire dalla macro se non ci sono dati nel foglio
es.:
If Range("A1").value = "" then exit sub

ciao

[raimea]

ciao
potrebbe essere corretto,
ma non saprei dove piazzare ,

Codice: Seleziona tutto

If Range("A1").value = "" then exit sub

A1 ? riferita a quale foglio ?

ciao

[Anthony47]

Quando un sito non risponde alla webquery la macro rimane appesa per circa 20 minuti, e con se tutto il foglio.
Puo' essere utile passare ad una automazione tramite InternetExplorer, come avevamo fatto in questo caso: viewtopic.php?f=26&t=102190 e in particolare in questo messaggio: viewtopic.php?f=26&t=102190#p591503
Con la macro GetTabRaim22 (evoluzione di un codice sviluppato per te...) viene gestito anche il timeout sulla risposta del sito (impostato lì a 60 sec, ma puo' essere ridotto) e conseguente Retry.

Ciao

[raimea]

ciao
ho letto la discussione indicata del 21.6.14 h 2,28
riferita alla macro GetTabRaim22
http://www.pc-facile.com/forum/viewtopic.php?f=26&t=102190#p591503

ma in realta' non sono in grado di capire quali sono le parti che dovrei "prelevare"
e applicare alla mia ......

la macro get... comprende anche delle Function , in fondo
sarebbero da utilizzare anche quelle, x dare un time out ?

ciao

[Anthony47]

Ti rispondero' domani, porta pazienza...

[raimea]

nessuna fretta, ci mancherebbe !!

ciao

[Anthony47]

Humm.. ti ho detto che avrei risposto oggi, ma mi accorgo che avrei fatto meglio a chiederti anche il file per il testing.
Per non rimandare a dopodomani vado avanti alla cieca, probabilmente invece di colpire il bersaglio colpiro' qualcuno della giuria...
La mia migliore interpretazione di questo lavoro a braccio e' questo codice, da aggiungere alle tue macro:

Codice: Seleziona tutto

Function GetTabRaim222(ByVal uurrll As String, ByVal ttAAbb As Long, myDest As Range) As Variant
Dim BetFlag As Boolean, myColl, my2Coll, IE As Object, LnkCnt As Long
Dim myRetr As Long, I0 As Long, I As Long, myLink As Object
'
myUrl = uurrll  '  "http://www.betonews.com/table.asp?tp=2001&lang=en&dd=20&dm=5&dy=2014&df=1&dw=3"
Set IE = CreateObject("InternetExplorer.Application")
'
Refr:
With IE
'Debug.Print "---------"
    .navigate myUrl
    .Visible = True
End With
'wait for page...
myreS = ieWaitPage(IE, 1, 60)    'sessione, Stab Time, TimeOut time
If myreS <> 0 Then
    If myRetr < 5 Then
        myRetr = myRetr + 1
        GoTo Refr
    Else
        Rispo = MsgBox("3 errori sulla pagina; recuperare manualmente e poi:" _
            & vbCrLf & "-premere OK se recuperato" _
            & vbCrLf & "-premere CANCEL se non recuperabile e quindi Abort della raccolta", vbOKCancel)
        If Rispo <> vbOK Then GoTo AbortA
    End If
End If
myRetr = 0
'
'Leggi le tabelle
myDest.Cells(1, 1).Resize(100, 20).ClearContents

'Stop
DoEvents
''I = 5
Set myColl = IE.document.getElementsByTagName("TABLE")
''Set my2Coll = IE.document.getElementsByTagName("A")
If myColl.Length >= ttAAbb Then                    'Vedi "Edit" in fondo
    Set myitm = myColl(ttAAbb - 1)
Else
    GoTo AbortA
End If
For Each trtr In myitm.Rows
    For Each tdtd In trtr.Cells
        myDest.Cells(1, 1).Offset(kk, jj) = tdtd.innertext
        jj = jj + 1
    Next tdtd
    kk = kk + 1: jj = 0
Next trtr
GetTabRaim222 = 1           '1=Ok
'
''Stop     'Vedi testo
'
fineA:
'Chiusura IE
IE.Quit
Set IE = Nothing
Set myColl = Nothing
Exit Function
'
AbortA:
    GetTabRaim222 = 0       '0=Abort
    GoTo fineA
End Function

Sub myWait(ByVal myStab As Single)
Dim myStTim As Single
'
    myStTim = Timer
    Do          'wait myStab
        DoEvents
        If Timer > myStTim + myStab Or Timer < myStTim Then Exit Do
    Loop
End Sub


Function ieWaitPage(ByRef iEs As Object, ByVal myStab As Long, ByVal myTO As Long) As Long
'0=ok; 1=timeout su .Busy; 2=timeout su .ReadyState; 4=Altro errore
'
Dim myStTim As Single, FlErr As Long
'
On Error GoTo FatErr
myStTim = Timer
Call myWait(0.2)      'wait iniziale
'
With iEs
    Do While .Busy: DoEvents:
        If Timer > myStTim + myTO Or Timer < myTO Then FlErr = 1: Exit Do
        Loop    'Attesa not busy
    Do While .ReadyState <> 4: DoEvents
        If FlErr <> 0 Then Exit Do
        If Timer > myStTim + myTO Or Timer < myTO Then FlErr = FlErr + 2: Exit Do
        Loop 'Attesa documento
End With
If FlErr = 0 Then
aazzz = myStab

    Call myWait(myStab)
End If
    ieWaitPage = FlErr
Exit Function
FatErr:
    ieWaitPage = FlErr + 4
End Function

Oltre al classico blocco che naviga all'interno di una sessione di InternetExplorer (la GetTabRaim222 sotto forma di Function) e' presente la Function ieWaitPage, che ha il compito di attendere il completo caricamento della pagina ma controllando che non vada in timeout; in caso di timeout la navigazione viene ripetuta per max 5 volte prima di abortire. Il timeout e' programmabile, e nel codice listato sopra e' posizionato su 60 secondi.
La GetTabRaim222 si appoggia sulla ieWaitPage, che a sua volta usa la Sub myWait per realizzare attese impostate.
Questa architettura evidenzia la genesi stratiforme di questo codice.
La GetTabRaim222 va richiamata con l' url della connessione, il numero di tabella da importare (nel tuo caso mi pare sia la "25") e la cella da cui cominciare l' importazione (nel tuo caso mi pare sia G4).
Quindi, dopo aver messo tutto questo ambaradan, devi andare nel tuo codice e sostituire
Range("G4").Select
With Selection.QueryTable
'etc
'etc
End With
Con

Codice: Seleziona tutto

zzz = GetTabRaim222("http://www.betonews.com/table.asp?tp=2002&lang=en&dd=" & [ab3] & "&dm=" & [ab4] & "&dy=" & [ab5] & "&df=1&dw=3", 25, Range("G4"))


A fine operazione zzz dovrebe contenere 1 se l' importazione della tabella e' andata a buon fine, oppure 0 se l'importazione e' fallita.
All'interno della GetTabRaim222 ho inserito uno Stop assolutamente di prova, che serve a verificare visivamente che quanto importato corrisponda alla tabella visualizzata; completare quindi la macro premendo F5. Terminato il collaudo lo Stop va rimosso.

Ripeto, ho proceduto senza poter effettuare tutti i collaudi quindi procedi con dovuta cautela dopo aver fatto le copie di backup dei tuoi file.
Ad esempio non so se la presentazione della tabella tramite la GetTabRaim222 e' uguale a quella della webquery, o se vanno fatti degli aggiustamenti.
Insomma, se ci ho colto io griderei al miracolo; "altrimenti" per favore allega anche il file di prova con le istruzioni sul suo uso.

Ciao

Edit: Ho aggiornato la riga If myColl.Length > ttAAbb Then in If myColl.Length >= ttAAbb Then altrimenti non si importa da pagine con una sola tabella
Ho ridotto anche a 10 righe * 20 colonne l'area che viene ripulita prima di importare la tabella

[raimea]

ciao
siamo sulla buona strada,

ho apportato le tue modifiche e fino un certo punto ok
poi da errore dopo aver premuto F5 che da autorizzazione
a procedere.

allego il fie,e faccio descrizione.
la macro che preleva e' associata al puls preleva incontri+data
in fogl prono (in alto a dx)
e la data del gg da prelevare, e' quella scritta in rosso.

la macro si chiama Sub Rettangoloarrotondato2_Click()
ed e' in modulo1,
nel quale ho messo anche tue nuove istruzioni

viene usato un fogl d'appoggio nascosto chiamato partite

grazie

https://dl.dropboxusercontent.com/u/96374724/test-lugarino.rar

[Anthony47]

Sono in viaggio, ma ho potuto dare uno sguardo al file.

Mi pare che la tabella debba crearsi da B2 e non da G4, quindi modifica la call alla funzione (zzz = ecc ecc), mettendo Range("B2").
Poi c'è un problema con una tua userfunction che si ricalcola pesantemente a ogni cella compilata; metti quindi il Calcolo in manuale prima della call e in Automatico subito dopo.
Fai queste prove e aggiorna il.thread con l'esito.
Ciao

[raimea]

ciao
ho sostituito B2 in zzz....

c'è un problema con una tua userfunction che si ricalcola pesantemente a ogni cella compilata

ne avevo una mezza idea.!!

ho bloccato conteggi prima della call aggiorno quote

Codice: Seleziona tutto

'DISATTIVO LE APPLICATION PER VELOCIZZARE
'L'ESECUZIONE DELLA MACRO

Dim xlCal As XlCalculation
With Application
    .ScreenUpdating = False
    .EnableEvents = False
    xlCal = .Calculation
    .Calculation = xlCalculationManual
End With
'-----------------

Call aggiorno_quote ' aggiorno tutte lequote

Range("V4") = Range("Z2")

ho bloccato lo stop, lanciato la macro ma in realta' non succede nulla.
apre il sito/pagina dalla quale deve prelevare ma non succede piu nulla.

[Anthony47]

Non sono in grado di fare test, ancora per un paio di giorni; ripristina lo Stop per vedere se prima o poi finisce, togli Screenupdating=false per vedere se non fa proprio niente o se è lentissimo, metti il time out su 120 sec nel caso che sia lentissimo (è il secondo parametro nella call alla GetTabRaim222). Sempre che la tua Call Aggiorno_quote sia corretta (non ricordo una sub Aggiorno_quote nel tuo file).
Ciao

[raimea]

no problem,
finalmente sono in ferie alcuni giorni,
appena rientro faccio test richiesti .
x ora grazie

[raimea]

ciao

in fgl prono x i test impostare la data 25.6.15
(date successive il sito non ha messo partite on. linee)

ho bloccato i 2 stop

vedo aprire la pagina web correttamente con le partite 25.6

apre il sito/pagina dalla quale deve prelevare
ma poi si blocca.

forse dovuto alla funzion

Codice: Seleziona tutto

Function CountByColor(InRange As Range, _
WhatColorIndex As Integer, _
Optional OfText As Boolean = False) As Long
'
' This function return the number of cells in InRange with
' a background color, or if OfText is True a font color,
' equal to WhatColorIndex.
'
Dim Rng As Range
Application.Volatile True

For Each Rng In InRange.Cells
If OfText = True Then
CountByColor = CountByColor - _
(Rng.Font.ColorIndex = WhatColorIndex)
Else
CountByColor = CountByColor - _
(Rng.Interior.ColorIndex = WhatColorIndex)
End If
Next Rng

End Function


in mod 9
che drovebbe servire solo alla macro asian in modulo 9

tale function dovrtebbe partire solo in questo caso ma non so come
sistemare

[Anthony47]

Sono ripartito dal file che avevi allegato nel post del 26-6 mattina...
La Function CountByColor e' impostata con Application.Volatile True, quindi per definizione si ricalcolera' ad ogni "Calcolo" fatto da Excel.

Ho quindi messo in manuale il calcolo, e per test riportato ScreenUpdating = True (per vedere se la compilazione dei risultati non avviene o e' solo lenta); ho corretto la destinazione su B2

Codice: Seleziona tutto

Application.Calculation = xlCalculationManual
Application.ScreenUpdating = True                    '<< Solo per prova
'-------da antony--------------------------------
zzz = GetTabRaim222("http://www.betonews.com/table.asp?tp=2002&lang=en&dd=" & [ab3] & "&dm=" & [ab4] & "&dy=" & [ab5] & "&df=1&dw=3", 25, Range("B2"))
'-------------------


Ho rimosso la Application.Calculation = xlCalculationAutomatic subito prima di Call aggiorno_quote.
Ho ripristinato lo stop prima di "FineA:".
Ho inserito la data 26/6/2015 in PRONO!V3 e ho premuto il tasto Prelev.INCONTRI + Data Ult.Agg.

Si e' creata la finestra InternetExplorer e dopo pochi secondi nel foglio Partite era presente una tabella (sulla cui esattezza non mi impegno...); la Sub Rettangoloarrotondato2_Click continua rapidamente fino alla fine; il messaggio finale dice che vengono impiegati 25 secondi.

Mi accorgo anche di averti suggerito di modificare "il secondo parametro nella call alla GetTabRaim222" spacciandolo per il Timeout sulla connessione; ERRORE, quello e' il numero di tabella da importare; il timeout e' il terzo parametro della chiamata alla ieWaitPage;vedi la riga

Codice: Seleziona tutto

myreS = ieWaitPage(IE, 1, 60)    'sessione, Stab Time, TimeOut time


Insomma mi pare che le cose funzionicchino, una volta che Calculation e' tenuto su Manuale durante l'esecuzione della Sub Rettangoloarrotondato2_Click, ripristinandolo su Automatico prima di End Sub.

Mi accorgo pero' che la tua macro "richiama" una seconda WebQuery, e anche per questa bisognerebbe fare il discorso di sostituire la WebQuery con l'automazione tramite IE, altrimenti il problema da cui siamo partiti rimane presente al 50% (rischio di blocco della query e blocco per 20 minuti del pc).
Per questo, all' interno della Sub aggiorno_quote, sostituirai il blocco With Selection.QueryTable / End With

Codice: Seleziona tutto

con
zzz = GetTabRaim222("http://www.betonews.com/table.asp?tp=2001&lang=en&dd=" & [V1] & "&dm=" & [W1] & "&dy=" & [X1] & "&df=1&dw=3", 25, Range("B2"))

Ciao

[raimea]

ciao
ho letto ed applicato alla lettera tutti i passaggi sopra descritto
ho sostituito le WebQuery con l'automazione tramite IE

e TUTTO OK

ora faccio altri test

x ora grazie mille

ciao