faster running code

shortman_alan · January 7th, 2009, 05:28 PM

i have devaloped this code which looks through on document, sorts and formats it to my need and then seaches for data within a user defind date range and adds it. then does it for another document but this document has different formatting so it is a little different. it all works fine but it is a little slow. i have no doubt that my code is rather sloppy and unprofessional and as a result could be condenced or made to run faster.

Code:

Private Sub YTD_Click()
Dim wb As Workbook
Dim ws As Worksheet, ws2 As Worksheet
Dim LastItemRowD As Long, LastItemRowAA As Long
Dim intSourceStartCol As Integer, intSourceEndCol As Integer, LastItemColD As Integer, UrNum As Integer
Dim intCurrPeriodStartCol As Integer, intCurrPeriodEndCol As Integer, LastItemColAA As Integer, W1 As Integer, W2 As Integer, Sweek As Integer
Dim i As Long, j As Long, k As Long, x As Long, y As Long, z As Long, p As Long
'Dim lngTempRow1 As Long, lngTempRow2 As Long
Dim varDepts, varDeptCounts, varCategories, varStartEndRows, varStartEndCols, varData, varCats
Dim strMessage As String, strSumRange As String, strDept As String, strCategory As String, FileName As String, path As String, fullname As String, stringi As String, stringj As String
Dim datStartDate As Date, datEndDate As Date, datTest As Date

    Application.ScreenUpdating = False
    Application.EnableEvents = False
    AddIns("analysis toolpak").Installed = True


    FileName = "Asset Activity -PM Schedule Compliance Completed or Closed.xls"
    If IsWbOpen(FileName) Then
            Set wb = Workbooks(FileName)
                'wb.Activate
    
        Else
            path = "U:\AuRP\Maintenance\Planning & Scheduling\eAM Work Forecast Reports\PM Completion Rate"        'if documents are in the same diretory use path = ThisWorkbook.Path
            fullname = path & "\" & FileName
            Set wb = Workbooks.Open(FileName:=fullname)
    End If

Set ws = ThisWorkbook.Worksheets("List PM Activities")
Set ws2 = Workbooks("Asset Activity -PM Schedule Compliance Completed or Closed.xls").Worksheets("PM Completed & Closed WO")

    ws.Unprotect
    With Me
    .Range("E3") = Now()
    .Range("C3") = Format(DateSerial(Year(Now()), 1, 1), "dd/mm/yyyy")
    ws.Range("I1") = .Range("C3")
    End With
    Module1.FillCal

        If ws.FilterMode = True Then
            ws.ShowAllData
        End If
        If ws2.FilterMode = True Then
            ws2.ShowAllData
        End If
    

ws2.Range("H:H").Clear

    LastItemColD = Module1.LastCell(ws).Column
    LastItemRowD = Module1.LastCell(ws).Row
    
    LastItemColAA = Module1.LastCell(ws2).Column
    LastItemRowAA = Module1.LastCell(ws2).Row
    
    For i = 2 To LastItemRowD
            stringi = ws.Range("B" & i & "")
            UrNum = GetUrgency(stringi)
      If CStr(ws.Range("H" & i & "")) <> "SAFETY/HEALTH" Then
        If UrNum > 1000 Then
            ws.Range("H" & i & "") = "REGULATORY REQUIREMENT"
        End If
      End If
    Next i
    
    For i = 6 To LastItemRowAA
            stringi = ws2.Range("B" & i & "")
            UrNum = GetUrgency(stringi)
      If CStr(ws2.Range("G" & i & "")) <> "SAFETY/HEALTH" Then
        If UrNum > 1000 Then
            ws2.Range("G" & i & "") = "REGULATORY REQUIREMENT"
        End If
      End If
    Next i
    
    
    'removes unneeded extras
        With ws
            .Activate
            .Range("G2").Select
            .Range(Selection, Selection.End(xlDown)).Select
        SortAndClip ("-PM")
        SortAndClip ("-PE")
        SortAndClip ("-PR")
        SortAndClip ("-CTR")
        SortAndClip ("-CTE")
        SortAndClip ("-R")
        SortAndClip ("-M")
        SortAndClip ("-E")
            .Range("A1").Activate
        End With
        With ws2
            .Activate
            .Range("C6").Select
            .Range(Selection, Selection.End(xlDown)).Select
        SortAndClip ("-PM")
        SortAndClip ("-PE")
        SortAndClip ("-PR")
        SortAndClip ("-CTR")
        SortAndClip ("-CTE")
        SortAndClip ("-R")
        SortAndClip ("-M")
        SortAndClip ("-E")
            .Range("A2").Activate
        End With
        
                'sort by dept & activity source:
        With ws2
    .Range(.Cells(6, 1), .Cells(LastItemRowAA, LastItemColAA)).Sort _
        Key1:=.Range("C6"), Order1:=xlAscending, _
        Key2:=.Range("G6"), Order2:=xlAscending, _
        Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal, DataOption2:=xlSortNormal
        End With
        With ws
    .Range(.Cells(1, 1), .Cells(LastItemRowD, LastItemColD)).Sort _
        Key1:=.Range("G2"), Order1:=xlAscending, _
        Key2:=.Range("H2"), Order2:=xlAscending, _
        Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal, DataOption2:=xlSortNormal
        End With

Const strMonthCount = "I3"
Const strDeptCol2 = "C"
Const strStartDate = "C3"
Const strEndDate = "E3"
Const strSourceActivityCol2 = "G"
Const strMonthCount2 = "I3"
Const strDeptCol = "G"
Const strSummaryDateStartCol = "B"
Const strSourceActivityCol = "H"

Const intSourceFirstCol = 10
Const intSourceDateRow = 1
Const intSummaryDateRow = 38
Const intSourceFirstRow = 5
Const intSourceDateCol = 4
Const intSummaryDateRow2 = 48
Const intSummaryDateRow3 = 58


    If ws.FilterMode = True Then ws.ShowAllData

    intSourceStartCol = 0
    intSourceEndCol = 0
        
    'set up the chart data headers:
    varCats = Array("HIGH PRIORITY", "EHS", "LOW PRIORITY")
    varCategories = Array("REGULATORY REQUIREMENT", "SAFETY/HEALTH", "STANDARD ACTIVITY")
   
    'clear the current data; format the date row:
    With Me
    .Range(Cells(intSummaryDateRow + 3, 2), Cells(Cells.Rows.Count, Cells.Columns.Count)).Clear
    .Rows(intSummaryDateRow).NumberFormat = "yyyy"
    .Rows(intSummaryDateRow).Font.Bold = True
    
    .Rows(intSummaryDateRow2).NumberFormat = "yyyy"
    .Rows(intSummaryDateRow2).Font.Bold = True
    
    .Rows(intSummaryDateRow3).NumberFormat = "yyyy"
    .Rows(intSummaryDateRow3).Font.Bold = True
    
    .Range("A" & intSummaryDateRow - 1 & "").Font.Bold = True
    .Range("A" & intSummaryDateRow - 1 & "") = "PLANNED"
    .Range("A" & intSummaryDateRow2 - 1 & "").Font.Bold = True
    .Range("A" & intSummaryDateRow2 - 1 & "") = "ACTUAL"
    .Range("A" & intSummaryDateRow3 - 1 & "").Font.Bold = True
    .Range("A" & intSummaryDateRow3 - 1 & "") = "% COMPLETION"
    End With
    
    ReDim varEOM(2)
        
    varEOM(LBound(varEOM)) = Me.Range("C3")
    varEOM(UBound(varEOM)) = Now()
    
    'write the selected period dates & categories:
        With Me
        .Range(strSummaryDateStartCol & intSummaryDateRow) = Now()
        .Range(Range(strSummaryDateStartCol & intSummaryDateRow).Address & ":" & Me.Range("D" & intSummaryDateRow).Address).HorizontalAlignment = xlCenterAcrossSelection
        
        .Range(strSummaryDateStartCol & intSummaryDateRow2) = Now()
        .Range(Range(strSummaryDateStartCol & intSummaryDateRow2).Address & ":" & Me.Range("D" & intSummaryDateRow2).Address).HorizontalAlignment = xlCenterAcrossSelection
        
        .Range(strSummaryDateStartCol & intSummaryDateRow3) = Now()
        .Range(Range(strSummaryDateStartCol & intSummaryDateRow3).Address & ":" & Me.Range("D" & intSummaryDateRow3).Address).HorizontalAlignment = xlCenterAcrossSelection
        End With
        
        For j = LBound(varCategories) To UBound(varCategories)
        With Me
            .Range(strSummaryDateStartCol & intSummaryDateRow + 1).Offset(0, j - 1).Value = varCats(j)
            .Range(strSummaryDateStartCol & intSummaryDateRow2 + 1).Offset(0, j - 1).Value = varCats(j)
            .Range(strSummaryDateStartCol & intSummaryDateRow3 + 1).Offset(0, j - 1).Value = varCats(j)
        End With
        Next j
    
    'find & write the unique list of depts:
    ReDim varDepts(1)
    j = 0
    For i = intSourceDateRow To LastItemRowD
        If ws.Range(strDeptCol & i).Value <> ws.Range(strDeptCol & i + 1).Value _
            And ws.Range(strDeptCol & i + 1).Value <> Empty Then
            j = j + 1
            ReDim Preserve varDepts(j)
            varDepts(j) = Trim(ws.Range(strDeptCol & i + 1).Text)
        End If
    Next i
    For i = LBound(varDepts) To UBound(varDepts)
        Me.Range("A" & intSummaryDateRow + 1 + i).Value = varDepts(i)
    Next i
    
    'define the row/col sum ranges within the dept/category/time period:
    ReDim varStartEndCols(2)
    'find the start/end columns of each period:
    varStartEndCols(1) = 10
    varStartEndCols(UBound(varEOM)) = Me.Range("E4").Value + 9
    
    'find the start/end rows of each category within each dept:
    j = LBound(varDepts)
    k = LBound(varCategories)
    ReDim varStartEndRows(UBound(varCategories) * 2, UBound(varDepts))
    For i = intSourceDateRow + 1 To LastItemRowD
        strDept = Trim(ws.Range(strDeptCol & i).Text)
        strCategory = Trim(ws.Range(strSourceActivityCol & i).Text)
        If strDept = varDepts(j) Then
            If strCategory = varCategories(k) Then
                If varStartEndRows(k * 2 - 1, j) = Empty Then
                    varStartEndRows(k * 2 - 1, j) = i   'set start row.
                    varStartEndRows(k * 2, j) = i       'set last row.
                Else
                    varStartEndRows(k * 2, j) = i       'increment last row.
                End If
            Else
                k = k + 1               'increment the category counter.
                If k > UBound(varCategories) Then
                    k = LBound(varCategories)
                    GoTo SkipRow
                End If
                i = i - 1               'retest the last row.
            End If
        Else
            j = j + 1                   'increment the dept counter.
            k = LBound(varCategories)   'reset the category counter.
            i = i - 1                   'retest the last row.
        End If
SkipRow:
    Next i
    varStartEndCols(UBound(varEOM)) = Me.Range("E4").Value + 9
    
    ReDim varData1(UBound(varDepts), UBound(varCategories))
    For i = LBound(varDepts) To UBound(varDepts)
        For j = LBound(varCategories) To UBound(varCategories)
                
                If varStartEndRows(j * 2 - 1, i) = Empty Or varStartEndCols(1) = Empty Or varStartEndRows(j * 2, i) = Empty Or varStartEndCols(2) = Empty Then
                    'skip it:
                Else
                    strSumRange = ws.Range(ws.Cells(varStartEndRows(j * 2 - 1, i), varStartEndCols(1)), ws.Cells(varStartEndRows(j * 2, i), varStartEndCols(2) - 1)).Address
                    'ws.Range(strSumRange).Select
                    varData1(i, j) = Application.WorksheetFunction.Sum(ws.Range(strSumRange))
                    If varData1(i, j) = Empty Then
                        varData1(i, j) = 0
                End If
                    End If
                    
           ' Next k
        Next j
    Next i
        
        
 ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' get actual
    'find & write the unique list of depts:
    ReDim varDepts(1)
    j = 0
    For i = intSourceFirstRow To LastItemRowAA
        If ws2.Range(strDeptCol2 & i).Value <> ws2.Range(strDeptCol2 & i + 1).Value _
            And ws2.Range(strDeptCol2 & i + 1).Value <> Empty Then
            j = j + 1
            ReDim Preserve varDepts(j)
            varDepts(j) = Trim(ws2.Range(strDeptCol2 & i + 1).Text)
        End If
    Next i
    For i = LBound(varDepts) To UBound(varDepts)
        Me.Range("A" & intSummaryDateRow2 + 1 + i).Value = varDepts(i)
        Me.Range("A" & intSummaryDateRow3 + 1 + i).Value = varDepts(i)
    Next i
'%'
    
'End%'
    
    'define the row/col sum ranges within the dept/category/time period:
    ReDim varStartEndRows(UBound(varCategories) * 2, 1)
    
   'find the start/end rows of each category within each dept:
    j = LBound(varDepts)
    k = LBound(varCategories)
    ReDim varStartEndRows(UBound(varCategories) * 2, UBound(varDepts))
    For i = intSourceFirstRow + 1 To LastItemRowAA - 1
        strDept = Trim(ws2.Range(strDeptCol2 & i).Text)
        strCategory = Trim(ws2.Range(strSourceActivityCol2 & i).Text)
        If strDept = varDepts(j) Then
            If strCategory = varCategories(k) Then
                If varStartEndRows(k * 2 - 1, j) = Empty Then
                   varStartEndRows(k * 2 - 1, j) = i   'set start row.
                   varStartEndRows(k * 2, j) = i       'set last row.
                Else
                    varStartEndRows(k * 2, j) = i       'increment last row.
                End If
            Else
                k = k + 1               'increment the category counter.
                If k > UBound(varCategories) Then
                    k = LBound(varCategories)
                    GoTo SkipRow2
                End If
                i = i - 1               'retest the last row.
            End If
        Else
            j = j + 1                   'increment the dept counter.
            k = LBound(varCategories)   'reset the category counter.
            i = i - 1                   'retest the last row.
        End If
SkipRow2:
    Next i
    
    
    
        ReDim varData(UBound(varDepts), UBound(varCategories), UBound(varEOM) - 1)
    
    ws2.Range("H:H").ClearContents
      For p = intSourceFirstRow + 1 To LastItemRowAA - 1
        datTest = ws2.Range("D" & p & "")
        ws2.Range("A4").Formula = "=WEEKNUM(" & ws2.Range("D" & p & "").Address & ")"
            If Me.Range("E4") >= ws2.Range("A4") And ws2.Range("A4") >= Me.Range("C4") And Year(datTest) = Year(varEOM(2)) Then
                ws2.Range("H" & p & "") = ws2.Range("H" & p & "") + 1
            End If
      Next p
     
    
    ReDim varData(UBound(varDepts), UBound(varCategories))
    For i = LBound(varDepts) To UBound(varDepts)
        For j = LBound(varCategories) To UBound(varCategories)

                If varStartEndRows(j * 2 - 1, i) = Empty Or varStartEndRows(j * 2, i) = Empty Then
                    'skip it:
                Else
                    strSumRange = ws2.Range(ws2.Cells(varStartEndRows(j * 2 - 1, i), 8), ws2.Cells(varStartEndRows(j * 2, i), 8)).Address
                    'ws.Range(strSumRange).Select
                    varData(i, j) = Application.WorksheetFunction.Sum(ws2.Range(strSumRange))
                    If varData(i, j) = Empty Then varData(i, j) = 0
                End If

        Next j
    Next i
        
   
    
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' end get actual
        
     
        
    'write the calculated data to the chart sheet:
    For i = LBound(varDepts) To UBound(varDepts)
        x = 0
            For k = LBound(varCategories) To UBound(varCategories)
                Me.Range(strSummaryDateStartCol & intSummaryDateRow).Offset(i + 1, x).Value = varData1(i, k)
                Me.Range(strSummaryDateStartCol & intSummaryDateRow2).Offset(i + 1, x).Value = varData(i, k)
                If Me.Range(strSummaryDateStartCol & intSummaryDateRow).Offset(i + 1, x).Value = Empty Then
                Else
                Me.Range(strSummaryDateStartCol & intSummaryDateRow3).Offset(i + 1, x).Value = FormatPercent(varData(i, k) / Me.Range(strSummaryDateStartCol & intSummaryDateRow).Offset(i + 1, x).Value, 0)
                 End If
                x = x + 1
        Next k
    Next i
 
 Workbooks("Asset Activity -PM Schedule Compliance Completed or Closed.xls").Save
 Workbooks("Asset Activity -PM Schedule Compliance Completed or Closed.xls").Close
    
    'and reset the data source for the chart:
    With Workbooks("Dash.xls").Charts("YTD")
    .Activate
    .SetSourceData Source:=Me.Range(Me.Cells(intSummaryDateRow3, 1), Me.Cells(intSummaryDateRow3 + i, x + 1)), PlotBy:=xlRows
    .HasTitle = True
    .ChartTitle.Text = "Dept Summary by Activity Category" & vbCrLf & "YTD"
    .Deselect
    End With
    
    GoTo NormalExit
    
ErrorExit:
    MsgBox (strMessage)
    
NormalExit:
    Application.ScreenUpdating = True
    Application.EnableEvents = True


End Sub

disregarding the functions i have used, i was wondering if this code could be made to run a bit faster.
cheers, alan

Shasur · January 7th, 2009, 08:54 PM

Hi

One option is to reduce the no of iterations. For example, the following code will loop through all cells in to check if value in column H, contains "SAFETY/HEALTH".

For i = 2 To LastItemRowD
stringi = ws.Range("B" & i & "")
UrNum = GetUrgency(stringi)
If CStr(ws.Range("H" & i & "")) <> "SAFETY/HEALTH" Then
If UrNum > 1000 Then
ws.Range("H" & i & "") = "REGULATORY REQUIREMENT"
End If
End If
Next i

Instead you can try the find method.

I have used the Excel findall method (http://vbadud.blogspot.com/2007/10/e...ll-method.html) to get all instances in an array and loop through the array

Cheers
Shasur

SolArch_ret · January 9th, 2009, 11:18 AM

Hi

This may or may not be a factor, but you have a couple places like
j = j + 1
ReDim Preserve varDepts(j)

I have found it better to do something like
j = j+1
If j > ubound(varDepts) then ReDim Preserve varDepts(j+1000)

then at end clean it back to Redim Preserve varDepts(j).

Also, I have found that performance can normally be gained in the code that is iterated through most often .... putting some counters in your loops that you can dump out with the debug.print may tell you where to look first.

It has been my experience that this will usually get you to 80% of the gain your are likely to make.

If you run long enough to get useful time intervals for your loops; that is even better.