Hi All,
I'm still quite new to programming and so don't know all the tips and tricks. Here is some code I have written to summaries customer purchase information. If you can see anything I can change to speed it up it would be much appreciated...
Its pretty long and taken me ages to do, but I'm sure there might just be some obvious little pointers. Thanks in advance!
I'm still quite new to programming and so don't know all the tips and tricks. Here is some code I have written to summaries customer purchase information. If you can see anything I can change to speed it up it would be much appreciated...
Its pretty long and taken me ages to do, but I'm sure there might just be some obvious little pointers. Thanks in advance!
Code:
Sub Forcasting()
Dim Arr() As Variant
Worksheets("Cash Accounts").Activate
Dim CA As Worksheet, MI As Worksheet, FC As Worksheet
Set CA = Worksheets("Cash Accounts")
Set MI = Worksheets("My Invoices")
Set FC = Worksheets("Forecasting")
LengthCust = WorksheetFunction.CountA(CA.Range("F:F")) + 3
Length = WorksheetFunction.CountA(MI.Range("A:A"))
Application.ScreenUpdating = False
Dim PurchaseDatesString As String, PurchaseVolume As String
InputRow = 1
CA.Activate
'%%%%%Cycle through customers%%%%%
For R = 1 To LengthCust
Items = CA.Range("F" & R).Value
AllItems = Split(Items, "; ")
WorkShip = CA.Range("A" & R).Value
On Error Resume Next
RowFound = WorksheetFunction.Match(WorkShip, MI.Range("AA:AA"), 0)
If Err = 1004 Then
On Error GoTo 0
GoTo NextCust
End If
RowEnd = RowFound + WorksheetFunction.CountIf(MI.Range("AA:AA"), WorkShip) - 1 'End of customer purchases
'%%%%% Cycle through Items for that customer %%%%%%
For Item = LBound(AllItems) To UBound(AllItems)
Old = ""
Recent = ""
Count = WorksheetFunction.CountIfs(MI.Range("C:C"), AllItems(Item), MI.Range("AA:AA"), WorkShip)
'%%%%% Get order frequency %%%%
On Error Resume Next
ItemRowFound = RowFound + WorksheetFunction.Match(AllItems(Item), MI.Range("C" & RowFound & ":C" & RowEnd), 0) - 1
If Err = 1004 Then
On Error GoTo 0
GoTo NextItem
End If
ItemRowEnd = ItemRowFound + WorksheetFunction.CountIfs(MI.Range("AA:AA"), WorkShip, MI.Range("C:C"), AllItems(Item)) - 1
PurchaseDatesString = ""
PurchaseVolume = ""
For RowN = ItemRowFound To ItemRowEnd
If PurchaseDatesString = "" Then
PurchaseDatesString = MI.Range("A" & RowN).Value2
PurchaseVolume = MI.Range("K" & RowN).Value2
Else
PurchaseDatesString = PurchaseDatesString & "; " & MI.Range("A" & RowN).Value2
PurchaseVolume = PurchaseVolume & "; " & MI.Range("K" & RowN).Value2
End If
Next RowN
OrderPrediction = FrequencyStats(PurchaseDatesString, PurchaseVolume)
'%%%%% Cycle through each item to get forecast of that item %%%%%
StartDate = MI.Range("A" & ItemRowFound).Value2
EndDate = MI.Range("A" & ItemRowEnd).Value2
For p = ItemRowFound To ItemRowEnd
If ItemRowEnd - ItemRowFound > 5 Then
CalcRate = 1.5
Else
CalcRate = 2
End If
CurrentItem = UCase(MI.Range("C" & p).Value)
OrderDate = MI.Range("A" & p).Value2
If AllItems(Item) = CurrentItem Then
If OrderDate < Date - OrderPrediction(2) * 3 Then
Old = "yes"
ElseIf OrderDate > Date - OrderPrediction(1) * CalcRate * 2 Then
Recent = "yes"
End If
End If
Next p
InputRow = InputRow + 1
FC.Range("C" & InputRow) = CurrentItem
If Old = "" And Recent = "yes" Then
Result = "New"
StartStopDate = StartDate
ElseIf Recent = "yes" And Old = "yes" Then
Result = "Existing"
StartStopDate = StartDate
ElseIf Recent = "" And Old = "yes" Then
Result = "Lost"
StartStopDate = EndDate
Else
Result = "Other"
StartStopDate = StartDate
End If
FC.Range("A" & InputRow) = CA.Range("B" & R).Value
FC.Range("B" & InputRow) = "'" & WorkShip
FC.Range("E" & InputRow) = WorksheetFunction.VLookup(CurrentItem, Worksheets("Product Categories").Range("A2:E17000"), 5, False)
FC.Range("F" & InputRow) = Round(OrderPrediction(3), 0) & "/" & Round((OrderPrediction(2)), 0) & " days"
'GainLoss Information
If Count = 1 Then
AverageDays = 0
Result = "One Purchase"
Worth = MI.Range("J" & RowN)
If Year(ResultDate) = Year(Date) Then
TyrLyr = 1
Else
TyrLyr = -1
End If
ThisYrGain = TyrLyr * Worth
ElseIf StartDate - EndDate = 0 Then
AverageDays = 0
Result = "One Purchase"
Worth = WorksheetFunction.Sum(MI.Range("J" & ItemRowFound & ":J" & ItemRowEnd))
If Year(ResultDate) = Year(Date) Then
TyrLyr = 1
Else
TyrLyr = -1
End If
ThisYrGain = TyrLyr * Worth
Else
AverageDays = OrderPrediction(2)
Worth = OrderPrediction(3) * (365 / AverageDays) * (MI.Range("J" & ItemRowEnd) / MI.Range("K" & ItemRowEnd))
If Result = "Lost" Then
Worth = -Worth
End If
ThisYr = 0
LastYr = 0
For p = ItemRowFound To ItemRowEnd
If Year(MI.Range("A" & p)) = Year(Date) - 1 Then
LastYr = LastYr + MI.Range("J" & p)
ElseIf Year(MI.Range("A" & p)) = Year(Date) Then
ThisYr = ThisYr + MI.Range("J" & p)
ElseIf Year(MI.Range("A" & p)) < Year(Date) - 1 Then
EarlierYr = ThisYr + MI.Range("J" & p)
End If
Next p
DailyLastYr = LastYr / 365
DailyThisYr = ThisYr / (DateValue(Now) - DateValue("1/1/" & Year(Date)))
DailyEalierYr = EarlierYr / 365
If DailyLastYr = 0 And DailyThisYr > 0 Then
TyrLyr = 1
ElseIf DailyThisYr = 0 And DailyLastYr > 0 Then
TyrLyr = -1
Else
TyrLyr = (DailyThisYr - DailyLastYr) / WorksheetFunction.Max(DailyLastYr, DailyThisYr)
End If
If DailyEalierYr = 0 And DailyLastYr > 0 Then
LyrPyr = 1
ElseIf DailyLastYr = 0 And DailyEalierYr > 0 Then
LyrPyr = -1
Else
LyrPyr = (DailyLastYr - DailyEalierYr) / WorksheetFunction.Max(DailyLastYr, DailyEalierYr)
End If
End If
FC.Range("D" & InputRow) = Result
FC.Range("H" & InputRow) = StartStopDate
FC.Range("G" & InputRow) = Result
FC.Range("I" & InputRow) = Worth
FC.Range("J" & InputRow) = TyrLyr
FC.Range("K" & InputRow) = LyrPyr
FC.Range("L" & InputRow) = Count
NextItem:
Next Item
NextCust:
Application.StatusBar = R & " of " & LengthCust & " Initial Update of Sale Summary"
Next R
End Sub
