Help Shorten Execution Time of VBA program

J

Jeff

Hi, I am a rather new programmer in VBA. I have written a program that
produces a receivables aging schedule based on customer terms. This is
intended to replace the aging report given by our accounting software which
doesn't account for different time periods when a given invoice may be
"current." Anyway, the program takes 17 minutes to execute on my system,
which is faster than the system that will use the program. Is there anyone
who would be up to scouring the following code for ways to make it faster? I
know I'm asking for a really big favor... but any tips/advice/help would be
appreciated.

Code follows:

Sub Custom_AR_Aging()

Application.ScreenUpdating = False
Dim vStart As Variant
Dim vEnd As Variant
Dim vElapsedtime As Variant

vStart = Time

Dim lrow As Long
Dim lrow2 As Long
Dim lrow3 As Long
lrow3 = 2

Dim llastrowCust As Long
Dim llastrowBill As Long

Dim vTerms As Variant
Dim vCustN As Variant

Dim wsCust As Worksheet
Dim wsBill As Worksheet
Dim wsAge As Worksheet

Dim dADate As Date

Dim cAgeCurrent As Currency
Dim cAge030 As Currency
Dim cAge3160 As Currency
Dim cAge6190 As Currency
Dim cAge91 As Currency

Dim cBalance As Currency
Dim vAge As Variant
Dim vRecord As Variant

Set wsCust = Workbooks("Custom Aging.xls").Worksheets("CustCode")
Set wsBill = Workbooks("Custom Aging.xls").Worksheets("Billing")
Set wsAge = Workbooks("Custom Aging.xls").Worksheets("Aging")

llastrowCust = wsCust.Cells(wsCust.Rows.Count, 1).End(xlUp).Row
llastrowBill = wsBill.Cells(wsBill.Rows.Count, 1).End(xlUp).Row

dADate = InputBox("Enter the 'as of' date for the Aging Schedule.")

wsAge.Activate
Cells.Select
Selection.Clear
Selection.ClearFormats

'The following For...Next loop goes through each customer code in the
'CustCode table and accumulates the open invoices for that customer from the
'billing table... each "terms code" is translated to a integer representing
the
'number of days an invoice is current under those terms.

For lrow = 2 To llastrowCust
vTerms = wsCust.Cells(lrow, "F").Value
vCustN = wsCust.Cells(lrow, "B").Value
If vTerms = "NET 10" Then
vTerms = 10
ElseIf vTerms = "NET 15" Then
vTerms = 15
ElseIf vTerms = "NET 30" Then
vTerms = 30
ElseIf vTerms = "NET 30 (INT)" Then
vTerms = 30
ElseIf vTerms = "SPECIAL" Then
vTerms = 30
ElseIf vTerms = "2%10NET30" Then
vTerms = 30
ElseIf vTerms = "2%10THPROX" Then
vTerms = 30
ElseIf vTerms = "NET 45" Then
vTerms = 45
ElseIf vTerms = "NET45" Then
vTerms = 45
ElseIf vTerms = "NET 60" Then
vTerms = 60
ElseIf vTerms = "NET60" Then
vTerms = 60
ElseIf vTerms = "2%15NET60" Then
vTerms = 60
ElseIf vTerms = "2% NET 60" Then
vTerms = 60
ElseIf vTerms = "NET 90" Then
vTerms = 90
ElseIf vTerms = "NET90" Then
vTerms = 90
ElseIf vTerms = "PREPAID CC" Then
vTerms = 0
ElseIf vTerms = "PREPAID CK" Then
vTerms = 0
ElseIf vTerms = "" Then
vTerms = 0
ElseIf vTerms = "PO CREDIT" Then
vTerms = 0
ElseIf vTerms = "COD" Then
vTerms = 0
ElseIf vTerms = "NET DUE" Then
vTerms = 0
ElseIf vTerms = "CASH" Then
vTerms = 0
ElseIf vTerms = "WASH" Then
vTerms = 0
ElseIf vTerms = "WIRE" Then
vTerms = 0
Else
MsgBox ("The Terms for a Customer Not Found: " & vbCr & _
vbCr & "Customer: " & vCustN & vbCr & _
"Terms: " & vTerms)
GoTo TheEnd
End If

'Here is where individual invoices are matched
'to the customer, and their balances are assigned
'to an aging bracket.
For lrow2 = 2 To llastrowBill Step 1
If wsBill.Cells(lrow2, "E").Value = wsCust.Cells(lrow, "A").Value
Then
If wsBill.Cells(lrow2, "G").Value > dADate Then 'Invoice not
within date range

ElseIf wsBill.Cells(lrow2, "G").Value <= dADate Then 'Invoice is
within date range
If wsBill.Cells(lrow2, "D").Value = "U" Then

cBalance = wsBill.Cells(lrow2, "I").Value -
wsBill.Cells(lrow2, "J").Value
vAge = dADate - wsBill.Cells(lrow2, "G").Value
If vAge <= vTerms Then
cAgeCurrent = cAgeCurrent + cBalance
ElseIf vAge <= vTerms + 30 Then
cAge030 = cAge030 + cBalance
ElseIf vAge <= vTerms + 60 Then
cAge3160 = cAge3160 + cBalance
ElseIf vAge <= vTerms + 90 Then
cAge6190 = cAge6190 + cBalance
ElseIf vAge > vTerms + 90 Then
cAge91 = cAge91 + cBalance
End If
ElseIf wsBill.Cells(lrow2, "D").Value = "P" Then
If wsBill.Cells(lrow2, "H").Value > dADate Then 'Invoice
was paid after date specified

cBalance = wsBill.Cells(lrow2, "I").Value -
wsBill.Cells(lrow2, "J").Value
vAge = dADate - wsBill.Cells(lrow2, "G").Value
If vAge <= vTerms Then
cAgeCurrent = cAgeCurrent + cBalance
ElseIf vAge <= vTerms + 30 Then
cAge030 = cAge030 + cBalance
ElseIf vAge <= vTerms + 60 Then
cAge3160 = cAge3160 + cBalance
ElseIf vAge <= vTerms + 90 Then
cAge6190 = cAge6190 + cBalance
ElseIf vAge > vTerms + 90 Then
cAge91 = cAge91 + cBalance
End If
ElseIf wsBill.Cells(lrow2, "H").Value <= dADate Then

Else
MsgBox ("Error #1 during invoice evaluation.")
GoTo TheEnd
End If
Else
MsgBox ("Error #2 during invoice evaluation.")
GoTo TheEnd
End If
End If
End If
Next lrow2

'Fill in Aging Schedule for the current customer
vRecord = 0
vRecord = cAgeCurrent + cAge030 + cAge3160 + cAge6190 + cAge91
If vRecord <> 0 Then
lrow3 = lrow3 + 1
wsAge.Cells(lrow3, "A").Value = wsCust.Cells(lrow, "A").Value
wsAge.Cells(lrow3, "B").Value = wsCust.Cells(lrow, "B").Value
wsAge.Cells(lrow3, "C").Value = wsCust.Cells(lrow, "AC").Value
wsAge.Cells(lrow3, "D").Value = cAgeCurrent
wsAge.Cells(lrow3, "E").Value = cAge030
wsAge.Cells(lrow3, "F").Value = cAge3160
wsAge.Cells(lrow3, "G").Value = cAge6190
wsAge.Cells(lrow3, "H").Value = cAge91
wsAge.Cells(lrow3, "I").Value = cAgeCurrent + cAge030 + cAge3160 +
cAge6190 + cAge91
End If
cAgeCurrent = 0
cAge030 = 0
cAge3160 = 0
cAge6190 = 0
cAge91 = 0
Next lrow

'Format the aging report
wsAge.Activate
Range("D2").Select
ActiveCell.FormulaR1C1 = "Current"
Range("E2").Select
ActiveCell.FormulaR1C1 = "0 to 30"
Range("F2").Select
ActiveCell.FormulaR1C1 = "31 to 60"
Range("G2").Select
ActiveCell.FormulaR1C1 = "61 to 90"
Range("H2").Select
ActiveCell.FormulaR1C1 = "90 +"
Range("I2").Select
Selection.Style = "Comma"
ActiveCell.FormulaR1C1 = "Total"
With ActiveCell.Characters(Start:=1, Length:=5).Font
.Name = "MS Sans Serif"
.FontStyle = "Regular"
.Size = 10
End With
Range("D1:I1").Select
Range("I1").Activate
With Selection
.HorizontalAlignment = xlCenter
End With
Selection.Merge
ActiveCell.FormulaR1C1 = "Aging"
Range("D1:I1").Select
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
Range("A2:B2").Select
Selection.Merge
With Selection
.HorizontalAlignment = xlLeft
.MergeCells = True
End With
ActiveCell.FormulaR1C1 = "Customer"
Range("D2:I2").Select
With Selection
.HorizontalAlignment = xlCenter
End With



TheEnd:
Application.ScreenUpdating = True
vEnd = Time
vElapsedtime = (vEnd - vStart) * 24 * 60 * 60
MsgBox ("Elapsed time: " & vElapsedtime & " sec.")

End Sub
 
J

Jeff

I'm sorry the indentation on the code did not "stick." Please let me know if
I can post it some other way to make it more readable.
 
P

Per Jessen

Hi Jeff

Avoid all select statements and try to off calculaton while running the
macro:

Sub Custom_AR_Aging()
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
Dim vStart As Variant
Dim vEnd As Variant
Dim vElapsedtime As Variant

vStart = Time

Dim lrow As Long
Dim lrow2 As Long
Dim lrow3 As Long
lrow3 = 2

Dim llastrowCust As Long
Dim llastrowBill As Long

Dim vTerms As Variant
Dim vCustN As Variant

Dim wsCust As Worksheet
Dim wsBill As Worksheet
Dim wsAge As Worksheet

Dim dADate As Date

Dim cAgeCurrent As Currency
Dim cAge030 As Currency
Dim cAge3160 As Currency
Dim cAge6190 As Currency
Dim cAge91 As Currency

Dim cBalance As Currency
Dim vAge As Variant
Dim vRecord As Variant

Set wsCust = Workbooks("Custom Aging.xls").Worksheets("CustCode")
Set wsBill = Workbooks("Custom Aging.xls").Worksheets("Billing")
Set wsAge = Workbooks("Custom Aging.xls").Worksheets("Aging")

llastrowCust = wsCust.Cells(wsCust.Rows.Count, 1).End(xlUp).Row
llastrowBill = wsBill.Cells(wsBill.Rows.Count, 1).End(xlUp).Row

dADate = InputBox("Enter the 'as of' date for the Aging Schedule.")

wsAge.Activate
Cells.Clear
Cells.ClearFormats

'The following For...Next loop goes through each customer code in the
'CustCode table and accumulates the open invoices for that customer from the
'billing table... each "terms code" is translated to a integer representing
the
'number of days an invoice is current under those terms.

For lrow = 2 To llastrowCust
vTerms = wsCust.Cells(lrow, "F").Value
vCustN = wsCust.Cells(lrow, "B").Value
If vTerms = "NET 10" Then
vTerms = 10
ElseIf vTerms = "NET 15" Then
vTerms = 15
ElseIf vTerms = "NET 30" Then
vTerms = 30
ElseIf vTerms = "NET 30 (INT)" Then
vTerms = 30
ElseIf vTerms = "SPECIAL" Then
vTerms = 30
ElseIf vTerms = "2%10NET30" Then
vTerms = 30
ElseIf vTerms = "2%10THPROX" Then
vTerms = 30
ElseIf vTerms = "NET 45" Then
vTerms = 45
ElseIf vTerms = "NET45" Then
vTerms = 45
ElseIf vTerms = "NET 60" Then
vTerms = 60
ElseIf vTerms = "NET60" Then
vTerms = 60
ElseIf vTerms = "2%15NET60" Then
vTerms = 60
ElseIf vTerms = "2% NET 60" Then
vTerms = 60
ElseIf vTerms = "NET 90" Then
vTerms = 90
ElseIf vTerms = "NET90" Then
vTerms = 90
ElseIf vTerms = "PREPAID CC" Then
vTerms = 0
ElseIf vTerms = "PREPAID CK" Then
vTerms = 0
ElseIf vTerms = "" Then
vTerms = 0
ElseIf vTerms = "PO CREDIT" Then
vTerms = 0
ElseIf vTerms = "COD" Then
vTerms = 0
ElseIf vTerms = "NET DUE" Then
vTerms = 0
ElseIf vTerms = "CASH" Then
vTerms = 0
ElseIf vTerms = "WASH" Then
vTerms = 0
ElseIf vTerms = "WIRE" Then
vTerms = 0
Else
MsgBox ("The Terms for a Customer Not Found: " & vbCr & _
vbCr & "Customer: " & vCustN & vbCr & _
"Terms: " & vTerms)
GoTo TheEnd
End If

'Here is where individual invoices are matched
'to the customer, and their balances are assigned
'to an aging bracket.
For lrow2 = 2 To llastrowBill Step 1
If wsBill.Cells(lrow2, "E").Value = wsCust.Cells(lrow, "A").Value
Then
If wsBill.Cells(lrow2, "G").Value > dADate Then 'Invoice not
within date range

ElseIf wsBill.Cells(lrow2, "G").Value <= dADate Then 'Invoice is
within date range
If wsBill.Cells(lrow2, "D").Value = "U" Then

cBalance = wsBill.Cells(lrow2, "I").Value -
wsBill.Cells(lrow2, "J").Value
vAge = dADate - wsBill.Cells(lrow2, "G").Value
If vAge <= vTerms Then
cAgeCurrent = cAgeCurrent + cBalance
ElseIf vAge <= vTerms + 30 Then
cAge030 = cAge030 + cBalance
ElseIf vAge <= vTerms + 60 Then
cAge3160 = cAge3160 + cBalance
ElseIf vAge <= vTerms + 90 Then
cAge6190 = cAge6190 + cBalance
ElseIf vAge > vTerms + 90 Then
cAge91 = cAge91 + cBalance
End If
ElseIf wsBill.Cells(lrow2, "D").Value = "P" Then
If wsBill.Cells(lrow2, "H").Value > dADate Then 'Invoice
was paid after date specified

cBalance = wsBill.Cells(lrow2, "I").Value -
wsBill.Cells(lrow2, "J").Value
vAge = dADate - wsBill.Cells(lrow2, "G").Value
If vAge <= vTerms Then
cAgeCurrent = cAgeCurrent + cBalance
ElseIf vAge <= vTerms + 30 Then
cAge030 = cAge030 + cBalance
ElseIf vAge <= vTerms + 60 Then
cAge3160 = cAge3160 + cBalance
ElseIf vAge <= vTerms + 90 Then
cAge6190 = cAge6190 + cBalance
ElseIf vAge > vTerms + 90 Then
cAge91 = cAge91 + cBalance
End If
ElseIf wsBill.Cells(lrow2, "H").Value <= dADate Then

Else
MsgBox ("Error #1 during invoice evaluation.")
GoTo TheEnd
End If
Else
MsgBox ("Error #2 during invoice evaluation.")
GoTo TheEnd
End If
End If
End If
Next lrow2

'Fill in Aging Schedule for the current customer
vRecord = 0
vRecord = cAgeCurrent + cAge030 + cAge3160 + cAge6190 + cAge91
If vRecord <> 0 Then
lrow3 = lrow3 + 1
wsAge.Cells(lrow3, "A").Value = wsCust.Cells(lrow, "A").Value
wsAge.Cells(lrow3, "B").Value = wsCust.Cells(lrow, "B").Value
wsAge.Cells(lrow3, "C").Value = wsCust.Cells(lrow, "AC").Value
wsAge.Cells(lrow3, "D").Value = cAgeCurrent
wsAge.Cells(lrow3, "E").Value = cAge030
wsAge.Cells(lrow3, "F").Value = cAge3160
wsAge.Cells(lrow3, "G").Value = cAge6190
wsAge.Cells(lrow3, "H").Value = cAge91
wsAge.Cells(lrow3, "I").Value = vRecord 'cAgeCurrent + cAge030 +
cAge3160 + cAge6190 + cAge91
End If
cAgeCurrent = 0
cAge030 = 0
cAge3160 = 0
cAge6190 = 0
cAge91 = 0
Next lrow

'Format the aging report
wsAge.Activate
Range("D2") = "Current"
Range("E2") = "0 to 30"
Range("F2") = "31 to 60"
Range("G2") = "61 to 90"
Range("H2") = "90 +"
With Range("I2")
.Style = "Comma"
.FormulaR1C1 = "Total"
With .Characters(Start:=1, Length:=5).Font
.Name = "MS Sans Serif"
.FontStyle = "Regular"
.Size = 10
End With
End With
With Range("D1:I1")
.HorizontalAlignment = xlCenter
.Merge
.FormulaR1C1 = "Aging"
With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
End With
With Range("A2:B2")
.Merge
.HorizontalAlignment = xlLeft
.MergeCells = True
.FormulaR1C1 = "Customer"
End With
Range("D2:I2").HorizontalAlignment = xlCenter




TheEnd:
With Application
.ScreenUpdating = True
.Calculation = xlAutomatic
End With
vEnd = Time
vElapsedtime = (vEnd - vStart) * 24 * 60 * 60
MsgBox ("Elapsed time: " & vElapsedtime & " sec.")

End Sub

Hopes this helps.
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

VBA Coding Help for Beginner 0
If then statement based on time of day 3
Help needed! Extracting Heading 3 and Contents from a Word Doc to Excel 0
Before Print - one worksheet only 2
Macro help 0
Help with this error "PasteSpecial method of Range class failed !! 0
VBA multiple list of values for variable 1
Checkbox linked to calcs 1

Top