Hi guys, I am new to VBA, I have done a code that does the following :
get me all the speed variations and classify each of them to create a sort of histogram.
Since a am pretty new to VBA, and to coding in general, my code is big and slow.
If anyone could give me some nice pointer on how to optimize it will be very appreciated!
(I got like 9817398172 for loops....)
The code do this sequence :
get the time and speed difference
get the variation on these datas.
find create duplicate of the datas if its on the same slope
delete the duplicates
find variation that has a difference of speed too small depending on the users input
classify each data depending on histogram resolution
End
get me all the speed variations and classify each of them to create a sort of histogram.
Since a am pretty new to VBA, and to coding in general, my code is big and slow.
If anyone could give me some nice pointer on how to optimize it will be very appreciated!
(I got like 9817398172 for loops....)
The code do this sequence :
get the time and speed difference
get the variation on these datas.
find create duplicate of the datas if its on the same slope
delete the duplicates
find variation that has a difference of speed too small depending on the users input
classify each data depending on histogram resolution
End
Code:
Sub SlopeCalculator2()
'Run "Doit"
'Application.ScreenUpdating = False
Dim PasteAreaRow, SpeedThreshold, HistogramResolution, StartingIndex, EndingIndex, Count As Integer
Dim PastTime, CurrentTime, DeltaTime, DeltaSpeed, AverageValue, LastAverageValue, MinValue, MaxValue, Binrange As Double
'Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False
Application.ScreenUpdating = False
'Application.DisplayStatusBar = True
Range("A3").Select
Selection.End(xlDown).Select
PasteAreaRow = ActiveCell.Row
For i = 3 To PasteAreaRow
PastTime = TimeValue(Range("A" & i - 1).Value)
CurrentTime = TimeValue(Range("A" & i).Value)
DeltaTime = (CurrentTime - PastTime) * 24 'gets the time in hour
PastSpeed = Range("B" & i - 1).Value
CurrentSpeed = Range("B" & i).Value
DeltaSpeed = CurrentSpeed - PastSpeed
Range("D" & i).Value = DeltaSpeed / DeltaTime 'variation of speed in a certain amount of time
Next i
For i = 3 To PasteAreaRow
For j = i To i + 1000
If Range("D" & i).Value > 0 And Range("D" & j).Value < 0 Then 'find the inflexion points
AverageValue = Application.Average(Range(Cells(i, 4), Cells(j - 1, 4))) 'calculate the average speed variation in between the infelxions
If AverageValue > 0 And Range("E" & i - 1).Value > 0 Then
AverageValue = LastAverageValue 'If the calculated values are the same sign, make them the same to remove them easier.
End If
Range("E" & i).Value = AverageValue
'Range("F" & i).Value = Abs(AverageValue)
Exit For
ElseIf Range("D" & i).Value < 0 And Range("D" & j).Value > 0 Then
AverageValue = Application.Average(Range(Cells(i, 4), Cells(j - 1, 4)))
If AverageValue < 0 And Range("E" & i - 1).Value < 0 Then
AverageValue = LastAverageValue
End If
Range("E" & i).Value = AverageValue
'Range("F" & i).Value = Abs(AverageValue)
Exit For
End If
LastAverageValue = AverageValue
Next j
Next i
'Run "Doit"
'Application.ScreenUpdating = False
SpeedThreshold = Application.InputBox _
(Prompt:="Please enter the minimum difference in speed on a slope (Speed threshold in Miles/hours).", _
Title:="Speed threshold", Type:=1)
For i = PasteAreaRow To 3 Step -1
If Range("E" & i).Value = Range("E" & i - 1).Value Then 'remove values on top of one another that are the same
Range("E" & i).Value = ""
End If
If Range("F" & i).Value = Range("F" & i - 1).Value Then 'remove values on top of one another that are the same
Range("F" & i).Value = ""
End If
Next i
For i = 3 To PasteAreaRow
If Range("E" & i).Value <> "" Then
StartingIndex = i
For j = i + 1 To i + 20
If Range("E" & j).Value <> "" Then
EndingIndex = j - 1
Exit For
End If
Next j 'get the row value of these datas.
DeltaSpeed = Range("B" & j).Value - Range("B" & i).Value 'remove small variations of speed
If Abs(DeltaSpeed) < SpeedThreshold Then
Range("E" & i).Value = ""
Range("E" & j).Value = ""
End If
End If
Next i
MaxValue = Application.Max(Range(Cells(1, 5), Cells(1000, 5)))
MinValue = Application.Min(Range(Cells(1, 5), Cells(1000, 5)))
'get the max and min to create a "histogram"
'Run "Doit"
'Application.ScreenUpdating = False
HistogramResolution = Application.InputBox _
(Prompt:="Please enter the Desired resolution for the histogram (quantity of bins).", _
Title:="Histogram Resolution", Type:=1)
For j = 0 To HistogramResolution
Binrange = (MaxValue - MinValue) / (HistogramResolution - 1)
Range("G" & j + 3).Value = MinValue + Binrange * j
'MsgBox MinValue & " " & MaxValue & " " & Binrange
Next j
For j = 0 To HistogramResolution
Count = 0
CurrentBinMin = Range("G" & j + 3).Value - 1
CurrentBinMax = Range("G" & j + 4).Value - 1
'MsgBox CurrentBinMin & " " & CurrentBinMax
For k = 3 To PasteAreaRow
If CurrentBinMax = -1 Or CurrentBinMin = -1 Then
Exit For
End If
CurrentAverage = Range("E" & k).Value
If CurrentAverage <> 0 And CurrentAverage > CurrentBinMin And CurrentAverage <= CurrentBinMax Then
Count = Count + 1
End If
Next k
Range("H" & j + 3).Value = Count
Next j
''
''For i = 3 To PasteAreaRow
''If Range("F" & i).Value > 0 Then
''Range("G" & i).Value = True
''Else
''Range("G" & i).Value = False
''End If
''
'''CurrentDiffTime = Range("D" & i).Value
'''CurrentDiffSpeed = Range("E" & i).Value
'''If CurrentDiffTime <> 0 Then
''' For j = i To i + 10
''' SlopeEnd = Range("E" & j).Value
''' If CurrentDiffTime > 0 And SlopeEnd < 0 Then
''' SlopeEndRow = j
''' End If
'''
''' If CurrentDiffTime < 0 And SlopeEnd > 0 Then
''' SlopeEndRow = j
''' End If
''' Next j
'''Range("G" & i).Value = j - i
'''Else
'''End If
''Next i
''
''PastValueSign = -1
''For i = 3 To PasteAreaRow
''ValueSign = Range("G" & i).Value
'' If ValueSign <> PastValueSign Then
'' Range("H" & i).Value = i - 1
'' End If
''PastValueSign = Range("G" & i).Value
''Next i
' Columns("H:H").Select
' Selection.SpecialCells(xlCellTypeBlanks).Select
' Selection.Delete Shift:=xlUp
' Range("I1").Select
'
'Range("H3").Select
'Selection.End(xlDown).Select
'PasteAreaRow = ActiveCell.Row
'pasteAreaColumn = ActiveCell.Column
'
'PastColumnValue = -1
'For i = 1 To PasteAreaRow
'ColumnValue = Range("H" & i).Value - 1
'
'If ColumnValue <> PastColumnValue Then
'Range("I" & i).Value = ColumnValue + 1
'End If
'PastColumnValue = Range("H" & i).Value
'Next i
'
' Columns("I:I").Select
' Selection.SpecialCells(xlCellTypeBlanks).Select
' Selection.Delete Shift:=xlUp
''
'Range("H3").Select
'Selection.End(xlDown).Select
'PasteAreaRow = ActiveCell.Row
'pasteAreaColumn = ActiveCell.Column
'
'For i = 1 To PasteAreaRow
'RowIndex = Range("H" & i).Value
'NextRowIndex = Range("H" & i + 1).Value
'dblAverage = Application.WorksheetFunction.Average(Worksheets(" Sheet1").Range("F" & RowIndex + 1 & ":F" & NextRowIndex))
'Range("J" & i).Value = dblAverage
'Next i
'Run "Doit"
'Application.Calculation = xlCalculationAutomatic
End Sub
'Calculate the average of a serie of slopes to get the average acceleration/decceleration.
Sub DoIt()
Application.ScreenUpdating = True
With Sheet2.Shapes("Rectangle 1")
.Visible = msoTrue = (Not Sheet2.Shapes("Rectangle 1").Visible)
End With
'Forces TextBox to show while code is running
Sheet1.Select
Sheet2.Select
End Sub
Sub SlopeCalculator3()
'Run "Doit"
'Application.ScreenUpdating = False
'Dim PasteAreaRow, SpeedThreshold, HistogramResolution, StartingIndex, EndingIndex, Count As Integer
Dim PastTime, CurrentTime, DeltaTime, DeltaSpeed, AverageValue, LastAverageValue, MinValue, MaxValue, Binrange As Double
Dim DeltaSpeedVarRay(10000) As Double
'Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False
Application.ScreenUpdating = True
'Application.DisplayStatusBar = True
'Range("A3").Select
'Selection.End(xlDown).Select
'PasteAreaRow = ActiveCell.Row
TimeRay = Range("A3:A" & Cells(Rows.Count, "A").End(xlUp).Row).Value
SpeedRay = Range("B3:B" & Cells(Rows.Count, "B").End(xlUp).Row).Value
For i = LBound(TimeRay, 1) To UBound(TimeRay, 1)
PastTime = TimeRay(i, 1)
CurrentTime = TimeRay(i, 1)
DeltaTime = CurrentTime - PastTime
PastSpeed = TimeRay(i, 1)
CurrentSpeed = TimeRay(i, 1)
DeltaSpeed = CurrentSpeed - PastSpeed
SpeedVar = DeltaSpeed / DeltaTime + 1 'variation of speed in a certain amount of time
DeltaSpeedVarRay(i) = SpeedVar
Next i
Range("C1:C" & UBound(DeltaSpeedVarRay) + 1) _
= WorksheetFunction.Transpose(DeltaSpeedVarRay)
End Sub