Hi,
Did not want to hijack Jonny's thread about ways in which to update and streamline code to make it run faster. The update speed of my first attempt at a macro is woefully slow - 5 minutes for 2.5K records. I was wondering if some of you more knowledgeable folk could look at my code and make suggestions as to how it could be modified to run faster.
When I ctrl-break out of it I usually end up in a private sub that concatenates columns A & B in Column C (see below). When it resorts the database it must keep triggering this concatenate sub which (I think) is slowing things down. Thanks go to Cringey for his suggestions in the other thread.
Concatenate Private Sub:
Option Explicit
Private Sub CommandButton1_Click()
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Cells.Count > 1 Or IsEmpty(Target) Then Exit Sub
If Not Intersect(Target, Range(Range("rReason").Offset(1, 0), Range("rReason"). _
Offset(UsedRange.Rows.Count + 1, 0))) Is Nothing Then
Target.Offset(0, 1) = Application.VLookup(Target, ValList.Range("ReasonLkUp"), 2, False)
End If
If Not Intersect(Target, Range(Range("rSurname").Offset(1, 0), Range("rSurname"). _
Offset(UsedRange.Rows.Count + 1, 0))) Is Nothing Then
Target.Offset(0, 1) = Target.Offset(0, -1) & " " & Target
End If
End Sub
Display More
Sort Database Module:Sorts database by date & smallest balance total. Also groups records by name of pupil.
Sub SortDataBase()
Dim calcMode As XlCalculation, updateMode As Boolean
calcMode = Application.Calculation
updateMode = Application.ScreenUpdating
Application.Calculation = xlManual
Application.ScreenUpdating = False
Application.ScreenUpdating = False
DBase.Activate
DBase.AutoFilterMode = False
DBase.Range(Range("rDataBase").Address, Range("J" & Range("A" & Rows.Count).End(xlUp).Row).Address).Sort _
Key1:=Range("rChristName"), Order1:=xlAscending, Key2:=Range("rSurname") _
, Order2:=xlAscending, Key3:=Range("rDate"), Order3:=xlAscending, Header:= _
xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Application.Calculation = calcMode
Application.ScreenUpdating = updateMode
Application.Calculate
End Sub
Display More
UpdateDatabase module: Updates a balance running total in column H. Calculates smallest running balance value by record (person).
Sub UpdateDatabase()
'This is Cringey's code designed to speed up VBA (part I)
Dim calcMode As XlCalculation, updateMode As Boolean
calcMode = Application.Calculation
updateMode = Application.ScreenUpdating
Application.Calculation = xlManual
Application.ScreenUpdating = False
Dim rOne As Range, rTwo As Range, rThree As Range, rFour As Range, rFive As Range, rSix As Range
Dim rBalUp As Range, rCell As Range, rSmallUp As Range
Set rOne = Range("G7:G35000")
Set rTwo = Range("C7:C35000")
Set rSix = Range("H7:H35000")
Set rBalUp = Range(DBase.Range("rBalCol").Offset(1, 0).Address, _
DBase.Range("rBalCol").Offset(DBase.Range("C" & Cells.Rows.Count).End(xlUp).Row - 6, 0).Address)
Set rSmallUp = Range(DBase.Range("rSmallest").Offset(1, 0).Address, _
DBase.Range("rSmallest").Offset(DBase.Range("C" & Cells.Rows.Count).End(xlUp).Row - 6, 0).Address)
If Range("G7") = "" Then
MsgBox "Database is empty or Reason not entered. Press OK to exit", vbOKOnly
Exit Sub
End If
SortDataBase
For Each rCell In rBalUp
Set rThree = Range("G7", rCell.Offset(0, -1).Address)
Set rFour = Range("C7", rCell.Offset(0, -5).Address)
Set rFive = Range("G7", rCell.Offset(0, -1).Address)
rCell = Evaluate("IF(" & rCell.Offset(0, -1).Value & _
">0,SUMPRODUCT(-(" & rOne.Address & "<0)*0.5,--(" & rTwo.Address & _
"=" & rCell.Offset(0, -5).Address & "))+SUMPRODUCT(--(" & _
rThree.Address & ">0),--(" & rFour.Address & "=" & rCell.Offset _
(0, -5).Address & ")," & rFive.Address & "),0)")
Next rCell
'CHANGE MAX BACK TO MIN IF IT DOESN'T WORK!!
For Each rCell In rSmallUp
rCell.FormulaArray = Evaluate("=IF(MIN(IF(" & rTwo.Address & _
"=" & rCell.Offset(0, -7).Address & ",IF(" & rSix.Address & ">0," & _
rSix.Address & ")))=" & rCell.Offset(0, -2).Value & ",MIN(IF(" & _
rTwo.Address & "=" & rCell.Offset(0, -7).Address & ",IF(" & _
rSix.Address & ">0," & rSix.Address & "))),0)")
Next rCell
' Application.ScreenUpdating = True
'This is Cringey's code designed to speed up VBA (part 2)
Application.Calculation = calcMode
Application.ScreenUpdating = updateMode
Application.Calculate
End Sub
Display More