VBA Efficiency 1

[Groves22]

I run a report during the first week of the month. It captures data monthly, and rolls it to YTD. The file isn't too bad now, but I know at the end of the year, the Excel profiles will be about 500MB+ (which I actually shrunk from 1.2GB)

I have some VBA that takes this file, and lumps a lot of info together... for an easier view to pass out.

I have some efficiency questions with some of my code... I'll post in parts, because the macro is just under 5200 lines! The goal is to make it run a tad quicker, as right now it takes 22-25 minutes per agent, for 95 (and growing) agents...

Here is my first chunk:

Sub OH_PA_In1()

Set NB_Temp = Workbooks("OH New Business - Template.xls")
Set scrap = Workbooks("Macro Scrap.xls")

Dim j As Long
j = 1

    Do Until scrap.Sheets(1).Range("C" & j) = "BI Limits"
        j = j + 1
    Loop

    With NB_Temp.Sheets(1)
        'BI Limits
        .Range("D7:D10").Value = scrap.Sheets(1).Range("D" & j + 1 & ":D" & j + 4).Value
        .Range("D11").Value = scrap.Sheets(1).Range("D" & j + 5).Value + scrap.Sheets(1).Range("D" & j + 6).Value + scrap.Sheets(1).Range("D" & j + 7).Value
        .Range("D12:D13").Value = scrap.Sheets(1).Range("D" & j + 8 & ":D" & j + 9).Value
        .Range("E7:E10").Value = scrap.Sheets(1).Range("F" & j + 1 & ":F" & j + 4).Value
        .Range("E11").Value = (scrap.Sheets(1).Range("E" & j + 5) + scrap.Sheets(1).Range("E" & j + 6) + scrap.Sheets(1).Range("E" & j + 7)) / (scrap.Sheets(1).Range("D" & j + 5).Value + scrap.Sheets(1).Range("D" & j + 6).Value + scrap.Sheets(1).Range("D" & j + 7).Value + 0.0001)
        .Range("E12:E13").Value = scrap.Sheets(1).Range("F" & j + 8 & ":F" & j + 9).Value
        .Range("F7").Resize(7, 1).Formula = "=IF(ISERROR(D7/D$13),0,D7/D$13)"

It's taking info from one sheet, and combining to fit the new condensed ranges. How's this look?

Thanks

 

[SkipVought]

Hi,

Youj do this loop in order to "find" the last row, I assume?

    Do Until scrap.Sheets(1).Range("C" & j) = "BI Limits"
        j = j + 1
    Loop

Instead, you could do a ...

Dim lNextRow as long
lNextRow = scrap.Sheets(1).Columns(2).find("BI Limits").row + 1

Or...

Dim lNextRow as long
lNextRow = scrap.Sheets(1).cells(1,2).end(xldown).row + 1

assuming that your range is contiguous from C1 down to the end of the used range.

Skip,
[sub]
Just traded in my old subtlety...
for a NUANCE![/sub]

 

[Groves22]

Thanks Skip!

How about this next (this will prob be my last...) piece of code?

Sub OH_Run()

Dim response

MsgBox "Please provide the dates for the profiles.", vbOKOnly, "Dates needed."

If OHNBPA = "Yes" Or OHNBHO = "Yes" Then    'Storing the date of the profiles. Used to open the files
101
    OHNYear = InputBox("Please enter year for Ohio NB:", "Year", "0000")     'Year
    OHNMonth = InputBox("Please enter month (##) for Ohio NB:", "Month", "00")   'Month
    OHNDay = InputBox("Please enter day (##) for Ohio NB:", "Day", "00")    'Day
    
    response = MsgBox("Is " & OHNMonth & "/" & OHNDay & "/" & OHNYear & " the correct date?", vbYesNo, "Verify")    'Verify date
    
        If response = 7 Then GoTo 101 'Wrong date, start over

End If

If OHNBPA = "Yes" Then  'If Yes is chosen on macro sheet, this will open the auto profile
    Workbooks.Open ("G:\Profile Reports\New Product Profiles\OH\Ohio NB Auto Profile " & OHNMonth & OHNDay & OHNYear & ".xls")
    Set OHNBPA_Prof = Workbooks("Ohio NB Auto Profile " & OHNMonth & OHNDay & OHNYear & ".xls")
End If

    
If OHNBHO = "Yes" Then  'If Yes is chosen on macro sheet, this will open the property profile
    Workbooks.Open ("G:\Profile Reports\New Product Profiles\OH\Ohio NB Property Profile " & OHNMonth & OHNDay & OHNYear & ".xls")
    Set OHNBHO_Prof = Workbooks("Ohio NB Property Profile " & OHNMonth & OHNDay & OHNYear & ".xls")
End If

    Workbooks.Open ("G:\Profile Reports\New Product Profiles\OH\Macro Items\Macro Scrap.xls")   'Open other files needed for abbrev profile
    Workbooks.Open ("G:\Profile Reports\New Product Profiles\OH\Macro Items\OH New Business - Template.xls")
    Set Agt_Macro = Workbooks("Agents Macro.xls")
    Set scrap = Workbooks("Macro Scrap.xls")
    Set NB_Temp = Workbooks("OH New Business - Template.xls")
    
Application.ScreenUpdating = False
    
    Agt_Macro.Sheets(1).Columns("J:K").ClearContents    'Erase any agent on the macro sheet
    
    If OHNBPA = "Yes" Then  'Copying the update agent list to past on macro sheet
        OHNBPA_Prof.Sheets("Profile").Range("Agt_Lkup").Copy
    ElseIf OHNBHO = "Yes" Then
        OHNBHO_Prof.Sheets("H3").Range("Agt_Lkup").Copy
    End If
    
    Agt_Macro.Sheets(1).Range("J2").PasteSpecial xlPasteValues
    Agt_Macro.Sheets(1).Range("J1:K1") = "All"  'All agents, together
    
    Dim agt_btm As Long
    agt_btm = Agt_Macro.Sheets(1).Range("J1").End(xlDown).Row   'Last row of agents
    
    Dim i As Long, WS As Long   'i = counter, WS = # of sheets in workbook
    i = 1
    
    Do Until i > agt_btm
    Application.Calculation = xlCalculationManual
        If OHNBPA = "Yes" Then
            scrap.Sheets(1).Cells.Delete    'Erase scrap sheet
            Agt_Macro.Sheets(1).Range("J" & i).Copy     'Copy the agent number to paste into auto profile
            OHNBPA_Prof.Sheets("Profile").Range("B4").PasteSpecial xlPasteValues
            
            For WS = 2 To 6     'Calculate each sheet 1 by 1
                OHNBPA_Prof.Sheets(WS).Calculate
            Next WS
                
            OHNBPA_Prof.Sheets("Profile").Cells.Copy    'Paste profile values info into scrap sheet
            scrap.Sheets(1).Cells.PasteSpecial xlPasteValues
            OHNBPA_Prof.Sheets("Profile").Cells.Copy    'Paste profile formats info into scrap sheet
            scrap.Sheets(1).Cells.PasteSpecial xlPasteFormats
            Agt_Macro.Sheets(1).Range("J" & i).Copy     'Copy agent number to paste into abbrev profile
            NB_Temp.Sheets(1).Range("C3").PasteSpecial xlPasteValues
            Agt_Macro.Sheets(1).Range("J" & i).Copy
            NB_Temp.Sheets(2).Range("C4").PasteSpecial xlPasteValues
            scrap.Save
            
    Application.Calculation = xlCalculationAutomatic
            Application.StatusBar = "Currently updating auto tab."
            Call OH_PA_In1  'Fill in abbrev profile ##LOOK FOR MORE EFFICIENT WAY##
            Call OH_PA_In2
            Call OH_PA_In3
            
            NB_Temp.Sheets(1).Range("PA_Temp").Value = NB_Temp.Sheets(1).Range("PA_Temp").Value
            NB_Temp.Sheets(1).Range("PA_Temp").Replace What:="#DIV/0!", Replacement:="0"
            
        End If

 

[SkipVought]

You do this inside the loop EVERY TIME!!!

            For WS = 2 To 6     'Calculate each sheet 1 by 1
                OHNBPA_Prof.Sheets(WS).Calculate
            Next WS

does ANYTHING change in this workbook within the loop? You might want to take it outside the loop and calc ONCE.

Also, no LOOP for the DO??? Is there more code?

Skip,
[sub]
Just traded in my old subtlety...
for a NUANCE![/sub]

 

[Groves22]

Hey Skip...

Yes, I need to calculate each time. The macro cycles through agents (i.e. 001, 002, 003, etc). The profile has different information for each one, which needs to be updated.

Also, there is a loop. I omitted the second part of that code, because it is identical to what is shown (except it's OHNBHO instead of OHNBPA).

And I made some minor tweaks with calucaltion, so that has def sped up the process. But do you see anything in the code that could use some more tweaking?

If you don't have the time to look, it's cool. I just want to learn the tricks, ya'know? Do you know a good place to read up on VBA tips? Does this site provide it somewhere?

Thanks,
Josh

 

[SkipVought]

So are you saying that OHNBPA_Prof.Sheets(WS).Calculate will get different results, based on some other workbook that was not open at the time that a previous calculate took place, but now is open?

For instance..

Workbooks open
A & B

Workbook B calculates only certain cells based on values in workbook A

Workbooks open
A, B, C & D

Workbook B calculates OTHER cells in addition to the ones previous, based on values in workbooks A, C & D

???



Skip,
[sub]
Just traded in my old subtlety...
for a NUANCE![/sub]

 

[DougAJ4]

Rather than working with range objects I'd recommend reading in the data as a variant array, working on that, then writing it back to the spreadsheet:

dim BigBlockofData as variant, BigBlockofData2 as variant
BigBlockofData = Range("name or address").value2

' Do some stuff on BigBlockofData
BigBlockofData2 = myfunction(BigBlockofData)

With Range("OutputRange")
.ClearContents
.ReSize(NumRows, NumCols).name = "OutputRange"
End With

Range("Outputrange").value = BigBlockofData2


Doing it this way can be orders of magnitude faster than working with ranges directly.

Doug Jenkins

http://newtonexcelbach.wordpress.com/

 

[Groves22]

So are you saying that OHNBPA_Prof.Sheets(WS).Calculate will get different results, based on some other workbook that was not open at the time that a previous calculate took place, but now is open?

The way the profile is set up:
-6 total tabs (Drvr, QYTD, IYTD, QMTD, IMTD, Profile)
-It quote to sales type profile, with every insurance pricing point possible
-The profile has an agent filter, when changed, the formulas on the YTD, MTD & Profile tabs need calculated

The VBA that I wrote, takes this profile and runs each agent through it. It will then take the print and paste a value copy so we can easily send it to the agents/marketing reps.

All of the calculations are dependent on OHNBPA_Prof tabs, not another workbook.

i.e.
agent 001 is selected: formulas on YTD/MTD tabs will show 001MP. The profile sheet uses this key for counts and sums
agent 002 is selected: formulas on YTD/MTD tabs will show 002MP. The profile sheet uses this key for counts and sums.


But after typing this out... I just thought of a way to enhance the profile workbook to make it run smoother.

Thanks

 

[Groves22]

Hey Skip...
You made me realize that I didn't need to calculate the YTD/MTD tabs every time... just the first 2. Here is my new logic:

            If z <= 2 Then
                For WS = 2 To 6
                    OHNBPA_Prof.Sheets(WS).Calculate
                Next WS
                z = z + 1
            Else
                OHNBPA_Prof.Sheets(6).Calculate
            End If

And Doug...
I don't quite understand what you are saying... could you expand a little?

Thanks

 

[SkipVought]

Good.

Often, when I build an application incrimentally over time, those kind of issues can affect performance.

You have to review the process and look for opportunities to pare off the fat.

Skip,
[sub]
Just traded in my old subtlety...
for a NUANCE![/sub]

 

[DougAJ4]

Groves22 - You seem to be doing a lot of work on the spreadsheet using VBA; e.g.

.Range("D710").Value = scrap.Sheets(1).Range("D" & j + 1 & "" & j + 4).Value
etc

I'm suggesting you could read the contents of your scap sheet(s) into an array, process that entirely within VBA, then write the results back to the spreadsheet in one operation, rather than hundreds or thousands. Looking at your later code extracts, that might be an awful lot of work, but it could give a huge speed improvement as well. Should be worth doing a trial anyway.


Doug Jenkins

http://newtonexcelbach.wordpress.com/

 

[Groves22]

DougAJ4 -
I'm suggesting you could read the contents of your scap sheet(s) into an array, process that entirely within VBA, then write the results back to the spreadsheet in one operation, rather than hundreds or thousands.

Ah... I will have to give it a try, when I get some free time! - Thanks

I do have another piece of code that seems to really bog down my computer. Is there a better way to run this?

 With P_Profile.Sheets(3)
     .Select
     [RED].Range("BJ3:DQ3").AutoFill Destination:=.Range(.Cells(3,62), .Cells(u,121))[/RED]
     .Range(.Cells(3,62), .Cells(u,121)).Calculate
End With

The red is what is hanging up my computer. It's taking the first row of formulas and "auto filling" them down to the last row of data. u = 3600+ rows at the moment. The calculation is set to xlCalculateManual so it's not updating the formulas that's slowing it down, it's the actuall process itself... Is there a better way?

 

[Groves22]

Also... is there a way to do some of these formulas in VBA, to help shrink the size of the file, and speed it up in the end?

=COUNTIF(QYTD!$BS$2:$BS$62611,IF($C$5="All",$B7&$C7,$C$5&$B7&$C7))
=SUMIF(QYTD!$BS$2:$BS$62611,IF($C$5="All",$B7&$C7,$C$5&$B7&$C7),QYTD!$V$2:$V$62611)

These are boosting the size of the file (180MB right now). Could VBA do the work in itself, and print the output in a ceratin range, like Doug has mentioned above?

If so... would it be hard to show a quick example?

Thanks,

 

[Gavona]

Record yourself editing the formula.

Then

With myRange
.formula=[as you recorded]
.calculate
.value=.value 'converts from formula to value


Gavin

 

[macropod]

I fully support the advice given by Groves22 about working with data arrays rather that repeatedly updating the workbook. In my own experience, Excel will initially update the wb very quickly, but with repeated updating it soon starts slowing down quite noticeably and eventually slows to a crawl. Put a timer in your loop and write the elapsed times for each loop to a scratch worksheet and you'll soon see the impact.

For a case I documented, see:

http://lounge.windowssecrets.com/index.php?showtopic=506460

Cheers
[MS MVP - Word]