Speed Up Code

[ianfrancis56]

All,

This code starts off really fast, something like 1 run through per second, but slows to a crawl after a while. Any help in resolving this issue and speeding it up in general would be greatly appreciated. Thanks!

Ian Francis

Private Declare Function URLDownloadToFile Lib "urlmon" _
    Alias "URLDownloadToFileA" ( _
        ByVal pCaller As Long, _
        ByVal szURL As String, _
        ByVal szFileName As String, _
        ByVal dwReserved As Long, _
        ByVal lpfnCB As Long) _
As Long
Sub GetData()
Application.ScreenUpdating = False

Dim DwnLoadOK As Boolean
Dim URL$, Dest$, i@, sym$
Dim old As Worksheet, wb As Workbook
Dim count@

count = 50
Set wb = ThisWorkbook

Application.DisplayAlerts = False
For Each old In wb.Worksheets
    If old.Name <> "Tick" Then
        old.Delete
    End If
Next old


On Error Resume Next
With Workbooks("Symb").Sheets("Tick")
    For i = 1 To .Range("A1").End(xlDown).Row
        sym = .Cells(i, 1).Value
        URL = "http://ichart.finance.yahoo.com/table.csv?s=" _
        & sym & "&d=8&e=26&f=2011&g=d&a=8&b=7&c=1900&ignore=.csv"
        Dest = "C:\Symbols\" & sym & ".csv"
        DwnLoadOK = DownloadFile(URL, Dest)
        Workbooks.Open ("C:/Symbols/" & sym & ".csv")
        Workbooks("Symb").Worksheets.Add(After:=Sheets _
        (Sheets.count)).Name = sym
        Workbooks(sym).Sheets(1).Range("A1:F" & .Range("F1").End(xlDown).Row).Copy _
        Destination:=Workbooks("Symb").Sheets(sym).Cells(1, 1)
        Workbooks(sym).Close
        Kill "C:\Symbols\" & sym & ".csv"
         
        With Workbooks("Symb").Sheets(sym)
            If .Cells(2, 1) <> "" Then
                .Cells(1, 7) = "ND Open"
                .Cells(1, 8) = "ND Close"
                .Cells(1, 9) = "ND High"
                .Cells(1, 10) = "ND Low"
                .Cells(1, 11) = "ND High R"
                .Cells(1, 12) = "ND Low R"
                .Cells(1, 13) = "ND R"
                .Cells(1, 14) = "R"
                .Cells(3, 7) = "=B2"
                .Cells(3, 8) = "=E2"
                .Cells(3, 9) = "=C2"
                .Cells(3, 10) = "=D2"
                .Cells(3, 11) = "=(C2-B2)/B2"
                .Cells(3, 12) = "=(D2-B2)/B2"
                .Cells(3, 13) = "=(E2-B2)/B2"
                .Cells(2, 14) = "=(E2-B2)/B2"
                .Cells(3, 7).Copy Destination:=.Range("G3:G" & _
                .Range("F3").End(xlDown).Row)
                .Cells(3, 8).Copy Destination:=.Range("H3:H" & _
                .Range("F3").End(xlDown).Row)
                .Cells(3, 9).Copy Destination:=.Range("I3:I" & _
                .Range("F3").End(xlDown).Row)
                .Cells(3, 10).Copy Destination:=.Range("J3:J" & _
                .Range("F3").End(xlDown).Row)
                .Cells(3, 11).Copy Destination:=.Range("K3:K" & _
                .Range("F3").End(xlDown).Row)
                .Cells(3, 12).Copy Destination:=.Range("L3:L" & _
                .Range("F3").End(xlDown).Row)
                .Cells(3, 13).Copy Destination:=.Range("M3:M" & _
                .Range("F3").End(xlDown).Row)
                .Cells(2, 14).Copy Destination:=.Range("N3:N" & _
                .Range("F3").End(xlDown).Row)
            Else: .Delete
            End If
        End With
        
      If i = count Then
         Shell "RunDll32.exe InetCpl.Cpl, ClearMyTracksByProcess 11"
        count = count + 50
    End If
    
    Next i
End With

Application.DisplayAlerts = True
End Sub
Sub fixreturn()
Dim old As Worksheet, symbol As Workbook
Dim last@

Set symbol = ThisWorkbook

For Each old In symbol.Worksheets
    last = old.Range("G3").End(xlDown).Row
    old.Cells(3, 7) = "=(E2-B2)/B2"
    old.Cells(3, 7).Copy Destination:=old.Range("G3:G" & last)
Next old

End Sub

Public Function DownloadFile( _
   URL As String, _
   SaveAsFileName As String) As Boolean

Dim lngRetVal As Long
    DownloadFile = False
    '// Lets try downloading 1st by URL
    '// If Not succesful then maybe settings
    '// are on Manual connect?
    '// so lets try forcing it !
    lngRetVal = URLDownloadToFile(0, URL, SaveAsFileName, 0, 0)
    '//
    If lngRetVal = 0 Then DownloadFile = True
End Function
[\CODE]

 

[CWatts]

You have application.screenupdating in there, but try putting in:

Application.Calculation = xlCalculationManual

'Your code

Application.Calculation = xlCalculationAutomatic

 

[AlphaFrog]

After you have placed all the formulas on the sheet, you can replace the formulas with the calculated values. This will help to speed things up and make the workbook file size smaller.

<font face=Courier New>    Lastrow = .Range("F3").End(xlDown).Row<br>    <SPAN style="color:#007F00">' Replace formulas with values</SPAN><br>    .Range("G3:N" & Lastrow).Value = .Range("G3:N" & Lastrow).Value</FONT>

 

[ianfrancis56]

Hey guys thanks! Those both helped a lot.

I have read that a For Each loop is faster than a For Next loop. How would I convert the above to a For Each loop? I tried but kept running into problems.

 

[Kenneth Hobson]

Example For loop.

Sub test()
 Dim cell As Range
 With ActiveSheet
  For Each cell In .Range("A1", .Range("A" & Rows.Count).End(xlUp))
   Debug.Print cell.Address, cell.Value
  Next cell
 End With
End Sub

Here is what I use for speed.
http://vbaexpress.com/kb/getarticle.php?kb_id=1035