Give some of the code where you might think is giving delay. Sometimesyou
think it works well but actually, you may have used long drawn coding that
uses too much referencing. Old win98 was great because it used very little
graphics and ram. but WinXP uses a lot more ram and your sub routine maybe
extensive. Maybe if you break up the routine into several routines. Also if
a variable is no longer used in one part of the macro then "release" it as it
is still taking up memory.
eg: Dim intNum as integer
Dim strMsg as String
intNum=100
strMsg="If you have encoutered this message then an error has occurred."
(code)
intNum=0
strMsg=""
(more code)
- Show quoted text -
Hi Friends,
I have a button in report screen. I am writing the code and
calculation is set to manual as we can check the code shows -4135.
Also if i compare the execution time of each function compared to
excel 2000 it is 10 seconds more, Hence in the whole it makes it
nearly 1 minute on the whole slower. Same code takes less time in
excel 2000.
say
Sub btnSubmit_Click()
asutest False: aeetest False
kaReport.ColholFmtest
End Sub
Public Sub asutest(pEnabled As Boolean)
Application.ScreenUpdating = False
End Sub
Public Sub aeetest(pEnabled As Boolean)
Application.enableEvents = False
End Sub
Sub ColholFmtest()
Set mwksReportA = Worksheets("BookForm")
If MsgBox("Do you want to print the second page containing additional
information?", vbQuestion + vbYesNo, "Colleague Holiday Form") = vbYes
Then
Set mrngReportB = mwksReportA.Range("a1:w106")
Else
Set mrngReportB = mwksReportA.Range("a1:w73")
End If
kaPrint.Portrait
kaPrint.PageB
kaPrint.TITLEB
On Error Resume Next
With mwksReportA.PageSetup
.Zoom = False
.FitToPagesTall = 2
.FitToPagesWide = 1
End With
On Error GoTo 0
// Going to this function
kaReporttest.Colholtest
End Sub
Sub Colholtest()
Dim rI As Integer, rI1 As Integer
Dim sList As ListBox
Dim intAns As Integer
Dim objColl As New clsColleague
Dim strBadge As String
If Not mflgInitialised Then initialiseVariables
i = freports.LB_KADates.ListIndex
If freports.LB_KADates.ListIndex = 0 Then
[Holstart] = dateSoFY(1)
[adt.holb].value = [adt.hol1].value
[details1!a31:a35].EntireRow.hidden = False
Else
[Holstart] = dateSoFY(2)
[adt.holb].value = [adt.hol2].value
[details1!a31:a35].EntireRow.hidden = True
End If
For rI = 0 To freports.LB_KADepts.ListCount - 1
If freports.LB_KADepts.Selected(rI) = True Then
rI1 = 0
Do Until IsEmpty(ThisWorkbook.Worksheets("Data1").Range
("A3").offset(rI1, 0)) = True
If ThisWorkbook.Worksheets("Data1").Range("A3").offset
(rI1, 2) = freports.LB_KADepts.LIST(rI, 0) Then
strBadge = ThisWorkbook.Worksheets("Data1").Range
("A3").offset(rI1, 0).Text
Worksheets("Details1").Range("badge_number").value
= strBadge
//*************taking lot of time compared to
excel 2000
holRead
jhReport.populateBookFormtest
With mwksReportA
mrngReportB.PrintOut Copies:=1, Collate:=True
End With
End If
rI1 = rI1 + 1
Loop
End If
Next rI
For rI = 0 To freports.LB_Colleagues.ListCount - 1
If freports.LB_Colleagues.Selected(rI) = True Then
strBadge = ThisWorkbook.Worksheets("Data1").Range
("A3").offset(rI, 0).Text
Worksheets("Details1").Range("badge_number").value =
strBadge
//*************see this function where some functions are
called are taking time
holReadtest
jhReport.populateBookFormtest
With mwksReportA
mrngReportB.PrintOut Copies:=1, Collate:=True
End With
End If
Next rI
End Sub
Public Sub holReadtest()
Dim strBadge As String
strBadge = ThisWorkbook.Worksheets("Details1").Range
("Badge_Number").value
' 1. Validate the the badge number selected can be found on
Worksheet Data1
If Not checkBadge(strBadge) Then
MsgBox Prompt:="Error - the badge number " & strBadge & "
is invalid or does not exist." & vbNewLine & _
"The colleague data cannot been found in
the data tables." & String$(2, vbNewLine) & _
"Error Code - DET1-02-BNF Invalid Badge /
Badge not Found.", _
Buttons:=vbCritical + vbOKOnly, _
Title:="LIST Error"
Exit Sub
End If
' If not, report error, advising that NEW colleagues must be
entered via the Schedule Entry screen
' (Edit > Schedule Entry Screen)
' 2. Call function to read the booked / taken holiday hours and
the days (Data1,2,3)
//*************taking lot of time compared to excel 2000
If holBkdTknDaystest(jhReadData) = False Then Exit Sub
' 3. Call function to read the holiday entitlement and contractual
data items (Data8)
//*************taking lot of time compared to excel 2000
If getColleagueDetailstest() = False Then Exit Sub
' 4. Call "HOLROTA" replacement function to read CONTRACTED days
into rows 11,16...
' For now the existing HOLROTA subroutine should work!
//*************taking lot of time compared to excel 2000
holrotatest
End Sub
Sub holrotatest()
' Subroutine converts booked/taken DAYS into a binary value, using
single bits
' to represent individual days. Part days have separate values.
' All are represented within the jhDays enum.
Dim wksDet1 As Worksheet, rngRota As Range, rngHoliday As Range
Dim strBadge As String, strYear$(1 To 65), datWCD As Date
Dim y%, intNumRotas%, intRota%, intDay%, intWeek%, intWeeks%(1 To
4)
Set wksDet1 = ThisWorkbook.Worksheets("Details1")
strBadge = wksDet1.Range("Badge_number")
intNumRotas = ThisWorkbook.Worksheets("data8").Columns("A").Find
(what:=strBadge, LookAt:=xlWhole).offset(0, 28)
If intNumRotas = 0 Then
Exit Sub
End If
Set rngRota = Worksheets("Data9").Columns("A").Find
(what:=strBadge, LookAt:=xlWhole)
' This calculates the jhDays enumeration value for each of the 4
weekly rotas
For intRota = 0 To 3 ' To loop through the 4 possible
rotas
For intDay = 0 To 6 ' To loop through the days of the
week
' If the day has a start time...
If Not (IsEmpty(rngRota.offset(0, (intRota * 56) + (intDay
* 8) + 4))) Then
intWeeks(1 + intRota) = intWeeks(1 + intRota) + (2 ^
intDay)
End If
Next intDay
Next intRota
datWCD = weekComm(wksDet1.Range("holstart"))
For i = 1 To 13 ' Column number within the calendar
For y = 0 To 4 ' Block (row) number within the calendar
intWeek = (y * 13) + (i - 1)
intRota = (datWCD + (intWeek * 7) - ROTA_WEEK_ROOTDATE) /
7 Mod intNumRotas
wksDet1.Range("C11").offset(y * 5, i + 26).value = intWeeks
(intRota + 1)
Next y
Next i
End Sub
Sub cleandetail1test()
Dim wksD1 As Worksheet
Set wksD1 = ThisWorkbook.Worksheets("Details1")
Application.ScreenUpdating = False
With wksD1.Range("dt1.ylw")
.ClearContents
.Interior.ColorIndex = 19
.Locked = False
End With
wksD1.Range("dt1.orange").Interior.ColorIndex = 40
With wksD1.Range("dt1.clean")
.ClearContents
.Interior.ColorIndex = xlNone
End With
Set rInput = wksD1.Range("d13")
For i = 0 To 20 Step 5
For I1 = 0 To 12
If rInput.offset(i - 1, I1) <= (Date - Weekday(Date)) Then
With rInput.offset(i + 2, I1)
.Interior.ColorIndex = 19
.Locked = False
End With
Else
With rInput.offset(i + 2, I1)
.Interior.ColorIndex = xlNone
.Locked = True
End With
End If
Next I1
Next i
//Here it goes to a function which takes lot of time called
holidaypart string1 which takes lot of time
wksD1.Range("ad11:ap34").ClearContents
With wksD1.Range("e32
35")
.Interior.ColorIndex = xlNone
.Locked = True
End With
End Sub
Public Function holidayPartStringtest(ByVal pValue As Integer,
Optional pFullWeekNewLine As Boolean = True, _
Optional
pOldStyle As Boolean = False) As String
Dim n%, xFull%, xPart%
Dim flgFull As Boolean
If pValue < 0 Then
holidayPartString = "> Error <"
Exit Function
End If
If CBool(pValue And jhFullWeek) And pOldStyle = False Then
If pFullWeekNewLine Then
holidayPartString = "Full Week" & Chr$(10) & "["
Else
holidayPartString = "Full Week ["
End If
flgFull = True
End If
For n = vbSunday To vbSaturday
xFull = (2 ^ (n - 1))
xPart = (2 ^ (n + 7))
' If a full week is included, then...
If flgFull Then
' ...include the first letter for selected days, and...
If CBool(pValue And xFull) Then
holidayPartString = holidayPartString & Left(Format(n,
"ddd"), 1)
' ...a space for days not selected
Else
holidayPartString = holidayPartString & " "
End If
' If it's not a full week...
Else
' then include 2 letter representations of the FULL days
selected, and...
If CBool(pValue And xFull) Then
holidayPartString = holidayPartString & Left(Format(n,
"ddd"), 2) & " "
' ...add include a 2 letter representation with an
asterisk of the PART days selected.
ElseIf CBool(pValue And xPart) Then
holidayPartString = holidayPartString & Left(Format(n,
"ddd"), 2) & "* "
End If
End If
Next n
If flgFull Then
holidayPartString = holidayPartString & "]"
Else
holidayPartString = Trim$(holidayPartString)
End If
End Function
