Why does this run so slow?

[Slammedtgs]

Hi guys. I know I am new here, but my intentions are good. In a effort to save myself some time in a project I have for a class at school I wrote a macro to speed up the process. I showed the program to my teacher, and she said "wow this would be great to grade the students files" I realized I must be onto something, so I decided to improve the macro to "grade" the entire classes.

Please keep in mind, this is my first time writing in VBA, so if the program structure isn't optimal - I'm very new.

Any input would be Awesome! (* I used several snippits of code from various sources online)

This sheet gets adjusted stock prices from Yahoo Finance.. In total, I want 22 sheets to have the macro used on.. However, with the addition of the for loop that moves from sheet to sheet the time increased from about 30 seconds/sheet to anywhere from 3-7 minutes for eight sheets. I also believe the internet connection has nothing to do with it.

Sub GroupProtfolio()
Dim sstock As Range
Dim shtnm As String
Dim ticker As String
Dim stock As String
Dim startdate As String
Dim enddate As String
Dim day1 As String
Dim day2 As String
Dim month1 As String
Dim month2 As String
Dim year1 As String
Dim year2 As String
Dim rrange As String



' no calendar but still editable.
startdate = Sheets("Group 1").Range("ab5")
enddate = Sheets("Group 1").Range("ac5")

month1 = Month(startdate) - 1
month2 = Month(enddate) - 1
day1 = Day(startdate)
day2 = Day(enddate)
year1 = year(startdate)
year2 = year(enddate)
range1 = "b4:k4"
range2 = "c4"

Application.ScreenUpdating = False
Application.Calculation = xlManual

'MsgBox ("The can take 20 - 30 seconds; Data is from yahoo finance, was only designed for 70 historical dates. The screen might flash")

'calander to input start date/waits one second/opens calendar for ending date (easiest way I could think to do this)
'UserForm1.Show
'Application.Wait (Now() + "00:00:01")
'userform2.Show
'storing dates for finance.yahoo.com address
'month1 = Range("z100")
'day1 = Range("z101")
'year1 = Range("z102")
'month2 = Range("z103")
'day2 = Range("z104")
'year2 = Range("z105")

'starts loop to read in stock ticker sybmols in colums b-k
'For portfolio 1
'(this for loop was not in the original macro, I added it today to make it 'go forever')

For Each Worksheet In ActiveWorkbook.Worksheets
        shtnm = ActiveSheet.Name
        If shtnm = "Index Fund" Then
        rrange = "c4"
        Else
        rrange = "b4:k4"
        End If
For Each sstock In Sheets(shtnm).Range(rrange)
     ticker = sstock
     stock = sstock
    'Starts getting data from finance.yahoo.com
         With ActiveSheet.QueryTables.Add(Connection:= _
            "URL;http://finance.yahoo.com/q/hp?s=" + ticker + "&a=" + month1 + "&b=" + day1 + "&c=" + year1 + "&d=" + month2 + "&e=" + day2 + "&f=" + year2 + "&g=d" _
            , Destination:=Range("$a$100"))
         'un comment this and comment above to hard code dates * do this for each sub group*
         'With ActiveSheet.QueryTables.Add(Connection:= _
            '"URL;http://finance.yahoo.com/q/hp?s=" + ticker + "&a=00&b=29&c=2010&d=03&e=9&f=2010&g=d" _
           ' , Destination:=Range("$a$100"))
            .Name = "a100"
            .FieldNames = True
            .RowNumbers = False
            .FillAdjacentFormulas = False
            .PreserveFormatting = True
            .RefreshOnFileOpen = False
            .BackgroundQuery = True
            .RefreshStyle = xlOverwriteCells
            .SavePassword = False
            .SaveData = True
            .AdjustColumnWidth = False
            .RefreshPeriod = 0
            .WebSelectionType = xlSpecifiedTables
            .WebFormatting = xlWebFormattingNone
            .WebTables = "20"
            .WebPreFormattedTextToColumns = True
            .WebConsecutiveDelimitersAsOne = True
            .WebSingleBlockTextImport = False
            .WebDisableDateRecognition = False
            .WebDisableRedirections = False
            .Refresh BackgroundQuery:=False
        End With
    
      With Application
        calcmode = .Calculation
        .Calculation = xlCalculationManual
        '.ScreenUpdating = False
    End With

    'Fill in the two values that you want to delete*
    DeleteValue1 = "*dividend*"
    'DeleteValue2 = "$"

    With ActiveSheet

        'remove the AutoFilter
        .AutoFilterMode = False

        'Apply the filter
        .Range("A100:A" & .Rows.Count).AutoFilter Field:=1, _
        Criteria1:=DeleteValue1, Operator:=xlOr, Criteria2:=DeleteValue2

        With .AutoFilter.Range
            On Error Resume Next
            Set rng = .Offset(1, 0).Resize(.Rows.Count - 1, 1) _
                      .SpecialCells(xlCellTypeVisible)
            On Error GoTo 0
            If Not rng Is Nothing Then rng.EntireRow.Delete
        End With

        'Remove the AutoFilter
        .AutoFilterMode = False
    End With
       'Sheet with the data, you can also use Sheets("MySheet")
    With ActiveSheet

        'Firstly, remove the AutoFilter
        .AutoFilterMode = False

        'Apply the filter
        .Range("B100:B" & .Rows.Count).AutoFilter Field:=1, _
        Criteria1:=DeleteValue1, Operator:=xlOr, Criteria2:=DeleteValue2

        With .AutoFilter.Range
            On Error Resume Next
            Set rng = .Offset(1, 0).Resize(.Rows.Count - 1, 1) _
                      .SpecialCells(xlCellTypeVisible)
            On Error GoTo 0
            If Not rng Is Nothing Then rng.EntireRow.Delete
        End With

        'Remove the AutoFilter
        .AutoFilterMode = False
    End With

    With Application
        .ScreenUpdating = False
        .Calculation = calcmode
    End With
        
        'deletes unneeded data from download, shifts cells left
            Range("B100:F170").Select
            Selection.Delete Shift:=xlToLeft
        
        'sorts download oldest to newest, removes double enteries
        Range("B101:B170").Select
        Selection.Style = "Currency"
        Range("A101:B170").Select
        ActiveSheet.Sort.SortFields.Clear
        ActiveSheet.Sort.SortFields.Add Key:=Range( _
            "A101"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
            xlSortNormal
            With ActiveSheet.Sort
                .SetRange Range("A101:B170")
                .Header = xlNo
                .MatchCase = False
                .Orientation = xlTopToBottom
                .SortMethod = xlPinYin
                .Apply
             End With
                'Range("F4:F6").Select
                'ActiveSheet.Range("$a$101:$b$170").RemoveDuplicates Columns:=1, Header:=xlYes
        'copy to proper cell location
                        Application.DisplayAlerts = False
                        ActiveSheet.Range("a101:a170").Copy
                        Range("a5").Select
                        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                            :=False, Transpose:=False
                        ActiveSheet.Range("b101:b170").Copy
                        Range(sstock.Address).Offset(1, 0).Select
                        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                            :=True, Transpose:=False
                                                                                
        ' Deletes sstock data, clears cells, waiting for next sstock data
                Range("A100:B170").Select
                Selection.ClearContents 
Next
    If shtnm = "Index Fund" Then
    Exit For
    Else
    ActiveSheet.Next.Select
    End If

Next

'deletes date coded data from activesheet
'Range("z100:z106").Select
'Selection.ClearContents
'unprotects the data so users can change anything they want
    ActiveSheet.Unprotect

'Allows screen update and automatic calculation iterations
    Application.ScreenUpdating = True
    Application.Calculation = xlAutomatic


End Sub

 

[supdawg]

Get rid of all .Selects. They slow down your code and they are mostly unneeded.

Example:

Range("A100:B170").Select
Selection.ClearContents

Can be changed to
Range("A100:B170").ClearContents

 

[Slammedtgs]

Get rid of all .Selects. They slow down your code and they are mostly unneeded.

Example:

Range("A100:B170").Select
Selection.ClearContents

Can be changed to
Range("A100:B170").ClearContents

I removed them, it does seem to run slightly faster. Using a bandwidth monitor it look like I am only requesting 2-3mb of data. Timing the sheets, it takes about ~ 30 seconds, or 3 seconds per stock on a sheet.. I guess I should not complain, but before my last for loop it was about 17 seconds. ( it was 30 seconds on a laptop, not the desktop that I am currently on now)

Does this seem reasonable?

 

[supdawg]

Looks pretty good to me. I don't really see anything else that could speed up your code. But I am FAR from a master .