Excel Formatting VBA Automation - Speed Up Code (1 Viewer)

Status
Not open for further replies.

Rx_

Nothing In Moderation
Local time
Yesterday, 17:33
Joined
Oct 22, 2009
Messages
2,803
Many of my "reports" are acutally queries (or views) from SQL Server / Oracle Linked Tables that use VBA code to create Excel Workbooks.
The outputs can range into hundreds of thousands of records.

It is not just a data-dump into Excel. Threre are complex business rules that look at each record and for example highlight various cells for further analysis. Sometimes, the columns are side-by-side between a SQL Server and Oracle DB and the colors look at single Pairs of Cells to evaluate if they match. Those that do or don't are highlighted so further analysis can take place.

The SQL Views can run in a matter of seconds. But, the detailed VBA automation for matching and highlighting cells can take a long time.
After applying this code a report today dropped from taking 1,890 seconds down to 810 seconds. In another case, a 22 minute report dropped to 1.4 minutes. These were run on the latest I7 4th Generation with 16G of RAM plus my code invokes a function to raise Priority Thread Processing to High for both Access and Excel during the vba automation process.

WARNING: Follow the rules for this code placement
Activate the Code Block - then De-Activate the code block
WARNING: When the code is Activated, the step-by-step code will not show any activity on the Excel side during troubleshooting.

Wait until After creating the Excel object to use this code.
Activate:
Code:
objxl.ScreenUpdating = False
objxl.Calculation = xlCalculationManual 'To turn Off the automatic calculation
objxl.EnableEvents = False
objxl.ActiveSheet.DisplayPageBreaks = False

Small example of code to evalueate a pair of Oracle Data / SQL Server Data in Excel Cells. The typical number of records is about 20,000 rows.
Around 25 Column (pairs of Columns) are evaluated. Just this loop runs around 500,000 times. There are 3 other variations of this.
The SQL/Oracle Views including T-SQL Functions take about 11 seconds due to the slow VPN to Oracle. The setup for Excel and file saving take about 6 seconds. Some other vba formatting overhead takes about 18 seconds.
The VBA looping for formatting dropped from over 1,800 seconds to about 800 seconds. This is just one of the loops:

Code:
NavColumn = 5
RegColumn = 6
' Columns are in pair of Nav Reg - look at values per row and turn those that don't match red -
' Note   a  MyName  and MyNameABC - will match   but a MyNameABC  MyName will not match - There wasn't enough difference to justify running the huge code twice
For j = 5 To 55 Step 2
NavColumn = j
RegColumn = j + 1
        For i = 6 To LastRow
            If objxl.Cells(i, NavColumn).Value <> "" Then 'This will omit blank cells at the end (in the event that the column lengths are not equal.
                If InStr(1, objxl.Cells(i, RegColumn).Value, objxl.Cells(i, NavColumn).Value, vbTextCompare) > 0 Then
                    'You may notice in the above instr statement, I have used *  vbTextCompare *  instead of its numerical value, _
                    ' I find this much more reliable as Oracle returns Text value and SQL Server can return Numeric values.
                    ' NOTE they are already black and white - so comment them out - leaving should they want a Green pass color
                Else
 
                    DH_InWellDescName = DoesWellDescriptionEndWithDorH(CLng(objxl.Cells(i, 4)))
                    If DH_InWellDescName Then ' don't match > column 32
                        ' NOTE The non-match makes backgound and font RED - both columns since we don't know what one is wrong.
                        objxl.Cells(i, NavColumn).Interior.Color = RGB(156, 0, 6) 'Dark red background
                        objxl.Cells(i, NavColumn).Font.Color = RGB(255, 199, 206) 'Light red font color
                        objxl.Cells(i, RegColumn).Interior.Color = RGB(156, 0, 6) 'Dark red background
                        objxl.Cells(i, RegColumn).Font.Color = RGB(255, 199, 206) 'Light red font color
                        objxl.Cells(i, 4).Font.Color = RGB(200, 199, 206) 'NOTE if any cell turns color then make Reg ID Red to indicate column has one Red cell
                    Else
                        If NavColumn < 32 Then
                            objxl.Cells(i, NavColumn).Interior.Color = RGB(156, 0, 6) 'Dark red background
                            objxl.Cells(i, NavColumn).Font.Color = RGB(255, 199, 206) 'Light red font color
                            objxl.Cells(i, RegColumn).Interior.Color = RGB(156, 0, 6) 'Dark red background
                            objxl.Cells(i, RegColumn).Font.Color = RGB(255, 199, 206) 'Light red font color
                            objxl.Cells(i, 4).Font.Color = RGB(255, 199, 206) 'NOTE if any cell turns color then make Reg ID Red to indicate column has one Red cell
                            objxl.Cells(i, 4).Interior.Color = RGB(156, 0, 6) 'Dark red background
                        End If
                    End If
                End If
            End If
        Next i
Next j

De-Activate - Must be done before any Printer Setup VBA
Code:
 ' end speedup 
objxl.ScreenUpdating = True
objxl.Calculation = xlCalculationAutomatic 'To turn On the automatic calculation
objxl.EnableEvents = True
objxl.ActiveSheet.DisplayPageBreaks = True
Deactivate before Printer setup code
Example of Printer Setup code:
Code:
2620            .LeftMargin = objxl.Application.InchesToPoints(0.25)
2630            .RightMargin = objxl.Application.InchesToPoints(0.25)
2640            .TopMargin = objxl.Application.InchesToPoints(0.75)
2650            .BottomMargin = objxl.Application.InchesToPoints(0.75)
2660            .HeaderMargin = objxl.Application.InchesToPoints(0.3)
2670            .FooterMargin = objxl.Application.InchesToPoints(0.3)              
2680          .PrintHeadings = False
2690          .PrintGridlines = False
2700          .PrintComments = xlPrintNoComments
2710          .PrintQuality = 600
2720          .CenterHorizontally = False
2730          .CenterVertically = False
2740          .Orientation = xlLandscape ' or use  xlPortrait '
2750          .Draft = False
2760          .PaperSize = xlPaper11x17
2770          .FirstPageNumber = xlAutomatic
2780          .Order = xlOverThenDown
2790          .BlackAndWhite = False
              '.Zoom = 56
2800            .Zoom = False
2810            .FitToPagesWide = 1
2820            .FitToPagesTall = False
2830          .OddAndEvenPagesHeaderFooter = False
2840          .DifferentFirstPageHeaderFooter = False
2850          .ScaleWithDocHeaderFooter = True
2860          .AlignMarginsHeaderFooter = True
2870          .PrintTitleRows = "$1:$" & (intRowPos - 1)        ' repeats header row 1 to 5
2880          .LeftFooter = "Page &P of &N"
2890          .RightFooter = "&D"
2900        End With
 

Rx_

Nothing In Moderation
Local time
Yesterday, 17:33
Joined
Oct 22, 2009
Messages
2,803
Excel - Speed up VBA process for loop in formatting - the numbers

A little rehash of speeding up things using Excel Automation.
Using MSAccess, a Recordset of just over 30,000 records is pulled from SQL Server and placed into Excel using Excel automation.

The last Column 0 contains a number of 1 to 4.
Sort is by "Well Name" then by the 1 to 4.

This means that every time there is a new Well Name - there is a cooresponding number 1 in column O.
The rows with number 4 are a zero to many for the Well.
All together, there is a about 10,000 number 4.

The code has a loop to check each record to the RecordSet.Count.
Inside the loop, the Code consist of an If - Then - each with a nested If-Then.

Running this on a Pentium 3 Gen i7, the code with out the speed up took 7.75 Minutes to complete (just the loop)
Code:
' speedup ////////////////////////////////////////////////////// speedup code///  turn off to troubleshoot or debug
  objxl.ScreenUpdating = False
  objxl.Calculation = xlCalculationManual 'To turn off the automatic calculation
  objxl.EnableEvents = False
  objxl.ActiveSheet.DisplayPageBreaks = False
' speedup ////////////////////////////////////////////////////// speedup code///  turn off to troubleshoot or debug
 
2790    With objxl.ActiveWorkbook.ActiveSheet
          'objxl.ActiveWorkbook.ActiveSheet
2800          For i = intRowPos To intMaxRecordCount + intRowPos
2810            'If .Cells(i, "B").Value <> .Cells(i - 1, "B").Value Then
                If .Cells(i, "O").Value = 1 Then  ' 1st sorted order for Lease type
2820                    .Range(.Cells(i, "B"), .Cells(i, "J")).Font.FontStyle = "Bold"
                        .Range(.Cells(i, "B"), .Cells(i, "J")).Borders(xlTop).ColorIndex = xlAutomatic
                                    ' must set back to automatic xince Else statement changes style
                        .Range(.Cells(i, "B"), .Cells(i, "J")).Borders(xlTop).Weight = xlThick
 
2830            Else
2840                .Range(.Cells(i, "B"), .Cells(i, "F")).Font.ColorIndex = 16 'metalic gray
                    If .Cells(i, "O").Value = 4 Then
                            .Range(.Cells(i, "G"), .Cells(i, "H")).Font.FontStyle = "Bold"
                    End If
2850            End If
2860         Next i
2870  End With
          ' end bold columns on changed value  7.75 min for loop
        ' >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> Bold and Lighten <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
' speedup ////////////////////////////////////////////////////// speedup code///  turn off to troubleshoot or debug
        objxl.ScreenUpdating = True
        objxl.Calculation = xlCalculationManual 'To turn off the automatic calculation
        objxl.EnableEvents = True
        objxl.ActiveSheet.DisplayPageBreaks = True
' speedup ////////////////////////////////////////////////////// speedup code///
With the Speedup Code as shown above, the same process took
1.25 Minutes.
 
Status
Not open for further replies.

Users who are viewing this thread

Top Bottom