Ottimizzare/velocizzare macro

[niubbophys]

Un saluto a tutti!

Ho la seguente macro https://www.dropbox.com/s/5myntzrtixuwr ... q.xls?dl=0
Vorrei gentilmente alcuni consigli se c'è la possibilità di migliorarla al fine di una migliore esecuzione, sia in rapidità che pulizia di codice (mi sono accorto che alcune volte IE non si chiude come dovrebbe...)
Tenete presente che la macro è il risultato di tante "sotto macro" fuse insieme da me, prendendo le varie parti "qua e là" per i forum... Insomma da non esperto in materia mi sono arrangiato.
La macro per funzionare funziona, cerco solo l'aiuto di qualcuno che la possa rendere più fluida possibile.

Ringrazio anticipatamente.

Ps: ne ho anche una versione "temporizzata" sulla quale ho qualche problemino con application.wait Ma ve la sottopongo in un secondo momento.

[ricky53]

Ciao,
il file non sarà disponibile per tanto tempo, quindi, è preferibile che tu riporti il codice direttamente nel forum.
Sarà utile in futuro ad altri utenti.
Grazie.

[niubbophys]

Ciao,
il file non sarà disponibile per tanto tempo, quindi, è preferibile che tu riporti il codice direttamente nel forum.
Sarà utile in futuro ad altri utenti.
Grazie.

Ciao!

Scusa non ci avevo pensato a mettere il codice. Provvedo subito. Grazie e tanti saluti.

Codice: Seleziona tutto

Option Explicit
Const MAXISIN As Integer = 100
Private Sub cmdClear_Click()
   Dim s As Worksheet
   'elimina tutti i fogli eccetto 'Foglio1'
   Application.DisplayAlerts = False
   Application.ScreenUpdating = False
   For Each s In Worksheets
      If s.Name <> "Foglio1" Then
         s.Select
         ActiveWindow.SelectedSheets.Delete
      End If
   Next
   Application.DisplayAlerts = True
   Range("C2:AE999").ClearContents
   Range("AG1:AG999").ClearContents
   Range("AK16:AM65").ClearContents
   Application.ScreenUpdating = True
End Sub
Private Sub cmdScarica_Click()
   Dim s As Worksheet, i As Integer, r As Integer, ISIN As String, prec As String, URL As String, myRan As Range, c As Integer
   Dim t As Integer, ult As Integer, titolo As String, N As Long, NT As Long, p As Integer, FASCIA As Integer
   Dim ie As Object, z As Integer
   Dim Doc As HTMLDocument
   Dim Stats As Object, Stat As Object
   Dim kfirst As Range, k As Range, X As String, LR As Long, response As VbMsgBoxResult
   Dim y As String
   Dim indexOfThey As Integer
   Dim finalString As String
   Dim singola As Integer
   
   cmdClear_Click
   prec = "Foglio1"
   '-------------------------- crea i nuovi fogli
   For r = 2 To MAXISIN
      ISIN = UCase$(Trim$(Cells(r, 1)))   'prende l'ISIN da colonna A
      If ISIN = "" Then Exit Sub   'se vuoto: fine ISIN, fatto !
      titolo = Trim$(Cells(r, 2))
      If titolo = "" Then titolo = ISIN
      '--------per ogni ISIN in colonna A crea un foglio specifico
      Sheets.Add
      ActiveSheet.[A1] = "Ora"
      ActiveSheet.[B1] = "Prezzo"
      ActiveSheet.[C1] = "Volume"
      '...e lo sposta in fondo
      ActiveSheet.Name = titolo
      Sheets(titolo).Move After:=Sheets(prec)
      prec = titolo
     
      '-----cerca il valore dell'ultima pagina (prima parte, cerca tutti gli a href)
       
        For p = 13 To 1 Step -1
            Set ie = New InternetExplorer
            ie.Visible = False
            FASCIA = p
            ie.navigate "http://www.nasdaq.com/symbol/" & ISIN & "/time-sales?time=" & FASCIA '& "&pageno=1"
            Do
            DoEvents
            Loop Until ie.readyState = READYSTATE_COMPLETE
            Set Doc = ie.document
            Set Stats = Doc.getElementsByTagName("a")
            z = 0
                For Each Stat In Stats
                    Range("AG1").Offset(z, 0).Value = Stat.href
                    z = z + 1
                Next
            ie.Quit
            'Set ie = Nothing

'-----cerca il valore ultima pagina (seconda parte, negli a href scegli quelli con la pagina, prende l'ultimo e poi estrae il numero pagina)
            X = "pageno"
            Sheets("Foglio1").Activate
                Set kfirst = Columns(33).Find(What:=X, LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
                    If kfirst Is Nothing Then
                        'MsgBox ("Not found")
                         With Sheets("Foglio1")
                            LR = .Range("E" & Rows.Count).End(xlUp).Row
                            .Range("E" & LR + r - 1).Offset(0, 2 * p).Value = "pageno=1"
                        End With
                    Else
                        With Sheets("Foglio1")
                            LR = .Range("E" & Rows.Count).End(xlUp).Row
                            .Range("E" & LR + r - 1).Offset(0, 2 * p).Value = kfirst.Value
                        End With
                        Set k = Columns(33).FindNext(After:=kfirst)
                        While (Not kfirst.Address = k.Address)
                            With Sheets("Foglio1")
                                LR = .Range("E" & Rows.Count).End(xlUp).Row
                                .Range("E" & LR + r - 1).Offset(0, 2 * p).Value = k.Value
                            End With
                            Set k = Columns(33).FindNext(After:=k)
                        Wend
                    End If
               
        Sheets("Foglio1").Activate
        y = Cells(r, 5 + 2 * p)
        indexOfThey = InStr(1, y, "=")
        finalString = Right(y, Len(y) - indexOfThey + 0)
        Cells(r, 5 + 2 * p).Value = finalString
        y = Cells(r, 5 + 2 * p)
        indexOfThey = InStr(1, y, "=")
        finalString = Right(y, Len(y) - indexOfThey + 0)
        Cells(r, 5 + 2 * p).Value = finalString


           
      '-------------crea l'URL per la query
      URL = "URL;http://www.nasdaq.com/symbol/" & ISIN & "/time-sales?time=" & FASCIA & "&pageno="
      Sheets("Foglio1").Activate
      Range("AK16:AM65").ClearContents    'pulisce l'area dati
      Range("AK16:AM65").Select
      N = 0
      Cells(r, 4 + 2 * p) = N
      With Selection.QueryTable
        For i = 1 To Cells(r, 5 + 2 * p)
        .Connection = URL & CStr(i)
        .Refresh BackgroundQuery:=False
        ult = 15
            For t = 16 To 66
                If Cells(t, 37) = "" Then Exit For
                ult = t
            Next
        N = N + ult - 15
        Cells(r, 4 + 2 * p) = N 'contratti per fascia oraria
        Set myRan = Range(Range("AK16"), Range("AM" & CStr(t))) '.End(xlDown))
        myRan.Copy Destination:=Sheets(titolo).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
        If ult < 65 Then Exit For
        DoEvents
        Next
      End With
      Range("AG1:AG999").ClearContents
    Next
    Cells(r, 3) = 0
    For p = 1 To 13
        Cells(r, 3) = Cells(r, 3) + Cells(r, 4 + 2 * p) 'contratti totali per ISIN
    Next
nextISIN:
   Next
   Sheets("Foglio1").Activate
End Sub
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
   Dim r As Integer, w As Integer, ISIN As String, FASCIA As Integer
   Cancel = True
   r = Target.Row
   w = Target.Column
   If (w = 1 Or w = 2) And r > 1 Then
      ISIN = Trim$(UCase$(Cells(r, 1).Text))
      If ISIN <> "" Then
         ThisWorkbook.FollowHyperlink "http://www.nasdaq.com/symbol/" & ISIN & "/time-sales?time=" & FASCIA & "&pageno=1"
      End If
   End If
End Sub