with: Erik Oosterwal
Custom Search
|
' -----------------------------------------------------------------
'
' Peaksonly.XLS
'
' Written by: Erik P. Oosterwal
' Started on: August 19, 1997
' Completed: August 22, 1997
'
' Revision History:
'
' -----------------------------------------------------------------
' Title: FindPosPeaks Macro
'
' Author: Erik Oosterwal
' Date: August 18, 1997
'
' Description:
' This routine takes a column of sine wave data and finds the
' maximum values of each peak. The peak values are then copied
' to a new column along with the time that the peak occurred.
'
' The CurrentCell will be designated as a peak if:
' Previous2Cells < CurrentCell >= Next2Cells
'
' It is possible for a value to be recorded for up to three
' cells in a row. The method given above will only use the
' first value in a series of duplicate values as the peak.
'
' In order to assure better results, the first and last data
' cells are excluded from being considered as peaks.
'
' Requirements & Restrictions:
' 1. For 'good' results, the input data must have a smooth
' curve.
' 2. The time values must be in column A.
' 3. The macro must be started in the column you are searching.
' 4. There must be a clear column 5 columns to the right of the
' input data column.
' 5. There must be a clear column 5 columns to the right of the
' time data column.
' -----------------------------------------------------------------
Sub FindPosPeaks()
'Application.ScreenUpdating = False ' Turn off screen updates, we don't need to see what's
' going on.
' ---------------------------------------------
' Declare all variables used in this macro.
' ---------------------------------------------
Dim fltCurrentValue As Single ' The value contained in the current cell.
Dim fltNextValue As Single ' The value contained in the next cell.
Dim fltPreviousValue As Single ' The value contained in the previous cell.
Dim strWorkbook As String ' Name of this workbook. Just in case the user changes
' the name of the workbook, the macro needs to know
' what the name is.
Dim varCurrentCell As Variant ' The cell we're checking to see if it's a peak.
Dim varCurrentSheet As Variant ' The name of the current worksheet.
Dim varNextCell As Variant ' The next cell to be checked.
Dim varPreviousCell As Variant ' The cell that was checked during the last loop iteration.
strWorkbook = ActiveWorkbook.Name ' Get the name of this workbook.
varCurrentSheet = ActiveSheet.Name ' Get the name of the sheet that contains the data.
' ----------------------------------------------------------
' Get rid of the old data before starting with new data.
' ----------------------------------------------------------
Application.Range("e11").Activate
Range(ActiveCell, ActiveCell.Offset(0, 1).End(xlDown)).Delete
' -----------------------------------------------------------------
' Find the first data cell. Assign PreviousCell, CurrentCell,
' and NextCell.
' -----------------------------------------------------------------
Application.Range("b20").End(xlUp).Activate ' Arbitrarily pick "B20" as a starting point,
' then go to the top cell in the column.
varCurrentCell = ActiveCell.Address() ' Get the address of the new cell.
While Not IsNumeric(Range(varCurrentCell).Value) ' If the current cell is not
' numeric, then
Application.Range(varCurrentCell).Cells(2, 1).Activate ' Go down one cell,
varCurrentCell = ActiveCell.Address() ' Get the location of the new cell,
Wend ' and check the new cell.
varPreviousCell = ActiveCell.Address() ' Assign the first data cell to
' PreviousCell.
Application.Range(varPreviousCell).Cells(2, 1).Activate ' Go down one cell.
varCurrentCell = ActiveCell.Address() ' Assign the second data cell to
' CurrentCell.
Application.Range(varCurrentCell).Cells(2, 1).Activate ' Go down one cell.
varNextCell = ActiveCell.Address() ' Assign the third data cell to
' NextCell.
' -------------------------------------------------
' Do the following while NextCell is not empty:
' -------------------------------------------------
While Not IsEmpty(Range(varNextCell)) ' Check to see if the next cell contains data.
' -------------------------------------------------------------
' If CurrentCell is a peak, copy it to the cell five
' columns to the right. Copy the time information from
' column A to the left of the peak reading.
' -------------------------------------------------------------
fltPreviousValue = Range(varPreviousCell).Value ' Get the values of the previous,
fltCurrentValue = Range(varCurrentCell).Value ' current, and
fltNextValue = Range(varNextCell).Value ' next cells.
Range(varCurrentCell).Activate
If fltCurrentValue = RangeMax(ActiveCell.Offset(-2, 0), ActiveCell.Offset(2, 0)) And _
Range(varPreviousCell).Value < Range(varCurrentCell).Value And _
Range(varCurrentCell).Value >= Range(varNextCell).Value Then ' Check for peak.
Range(varCurrentCell).Select ' Select the value from the current cell
Selection.Copy (ActiveCell.Offset(0, 4)) ' and copy it to a cell 4 columns to
' the right.
Range(varCurrentCell).End(xlToLeft).Select ' Select the time value from column A and
Selection.Copy (ActiveCell.Offset(0, 4)) ' copy it to the cell next to the peak
' value.
End If
Application.Range(varCurrentCell).Activate ' Make sure that CurrentCell is the
' active cell.
' ---------------------------------------------------------------
' Reassign PreviousCell, CurrentCell, and NextCell to the
' next cell down.
' ---------------------------------------------------------------
varPreviousCell = ActiveCell.Address() ' Assign the current data cell
' to PreviousCell.
Application.Range(varPreviousCell).Cells(2, 1).Activate ' Go down one cell.
varCurrentCell = ActiveCell.Address() ' Assign the next data cell to
' CurrentCell.
Application.Range(varCurrentCell).Cells(2, 1).Activate ' Go down one cell.
varNextCell = ActiveCell.Address() ' Assign the third data cell to
' NextCell.
' --------------------
' End of the loop.
' --------------------
Wend
' --------------------------------------------------------------
' Move over to the column that has the peaks, and remove all
' the empty cells between the data.
' --------------------------------------------------------------
Application.Range(varCurrentCell).Cells(1, 4).Activate ' Move over 3 cells to the right.
Range(ActiveCell, "f11").Select ' Sort the peak data in descending
Selection.Sort key1:=ActiveCell, order1:=xlDescending ' order to move all the blank
' cells to the bottom.
Application.Range("e11").Activate ' Move to the top of the data.
Range(ActiveCell, ActiveCell.Offset(0, 1).End(xlDown)).Select ' Sort the resulting data in
Selection.Sort key1:=ActiveCell, order1:=xlAscending ' ascending order.
' ----------------------------------------------------------------
' Find the minimum, maximum, and average of the peaks, along
' with the standard deviation, printing this in an appropriate
' location.
' ----------------------------------------------------------------
Application.Range("f11").Activate
Range(ActiveCell, ActiveCell.End(xlDown)).Select
Range("f2").Value = Application.Min(Selection)
Range("f3").Value = Application.Average(Selection)
Range("f4").Value = Application.Max(Selection)
Range("f6").Value = Application.StDev(Selection)
Range("f7").Value = Application.AveDev(Selection)
' --------------------------------------------------------------
' Find the Strokes Per Minute (SPM) value, printing it in an
' appropriate location.
' --------------------------------------------------------------
Application.Range("e11").Activate
Range(ActiveCell, ActiveCell.End(xlDown)).Select
Range("e9").Value = Application.Count(Selection) / _
(Application.Max(Selection) - _
Application.Min(Selection)) / (24 * 60)
' ------------------------------
' End of FindPosPeaks Macro.
' ------------------------------
End Sub
' ----------------------------------------------------------------------------
' Title: RangeMax Function
'
' Author: Erik Oosterwal
' Date: August 20, 1997
'
' Description:
' This function returns the largest value in a given range of values.
'
' Requirements & Restrictions:
' The values in the range must be single precision floating point.
' ----------------------------------------------------------------------------
Function RangeMax(StartCell As Variant, EndCell As Variant) As Single
' --------------------------------------------
' Delcare variables used in this function.
' --------------------------------------------
Dim varWorkCell As Variant
' --------------------------------------------------------------------------
' Set the initial value for RangeMax to be the smallest number that will
' fit in a single precision float variable.
' --------------------------------------------------------------------------
RangeMax = -3.402823E+38
' ---------------------------------------------------------------------------
' Check each cell in the range to see if it contains numeric data. If it
' does, then compare it to the current value of RangeMax. If the current
' cell is larger that RangeMax, then reassign the value in the current
' cell to RangeMax.
' ---------------------------------------------------------------------------
For Each varWorkCell In Range(StartCell, EndCell) ' Check each cell in the range.
If IsNumeric(varWorkCell.Value) Then ' Make sure the data is numeric.
If varWorkCell.Value > RangeMax Then ' Compare the data to RangeMax.
RangeMax = varWorkCell.Value ' Reassign the value to RangeMax.
End If
End If
Next ' Check the next cell in the range.
' ---------------------------------
' End of the RangeMax Function.
' ---------------------------------
End Function
' -----------------------------------------------------------------
' Title: FindNegPeaks Macro
'
' Author: Erik Oosterwal
' Date: August 22, 1997
'
' Description:
' This routine takes a column of sine wave data and finds the
' minimum values of each peak. The peak values are then copied
' to a new column along with the time that the peak occurred.
'
' The CurrentCell will be designated as a peak if:
' Previous2Cells > CurrentCell <= Next2Cells
'
' It is possible for a value to be recorded for up to three
' cells in a row. The method given above will only use the
' first value in a series of duplicate values as the peak.
'
' In order to assure better results, the first and last data
' cells are excluded from being considered as peaks.
'
' Requirements & Restrictions:
' 1. For 'good' results, the input data must have a smooth
' curve.
' 2. The time values must be in column A.
' 3. The macro must be started in the column you are searching.
' 4. There must be a clear column 4 columns to the right of the
' input data column.
' 5. There must be a clear column 7 columns to the right of the
' time data column.
' -----------------------------------------------------------------
Sub FindNegPeaks()
'Application.ScreenUpdating = False ' Turn off screen updates, we don't need to see what's
' going on.
' ---------------------------------------------
' Declare all variables used in this macro.
' ---------------------------------------------
Dim fltCurrentValue As Single ' The value contained in the current cell.
Dim fltNextValue As Single ' The value contained in the next cell.
Dim fltPreviousValue As Single ' The value contained in the previous cell.
Dim strWorkbook As String ' Name of this workbook. Just in case the user changes
' the name of the workbook, the macro needs to know
' what the name is.
Dim varCurrentCell As Variant ' The cell we're checking to see if it's a peak.
Dim varCurrentSheet As Variant ' The name of the current worksheet.
Dim varNextCell As Variant ' The next cell to be checked.
Dim varPreviousCell As Variant ' The cell that was checked during the last loop iteration.
strWorkbook = ActiveWorkbook.Name ' Get the name of this workbook.
varCurrentSheet = ActiveSheet.Name ' Get the name of the sheet that contains the data.
' ----------------------------------------------------------
' Get rid of the old data before starting with new data.
' ----------------------------------------------------------
Application.Range("g11").Activate
Range(ActiveCell, ActiveCell.Offset(0, 1).End(xlDown)).Delete
' -----------------------------------------------------------------
' Find the first data cell. Assign PreviousCell, CurrentCell,
' and NextCell.
' -----------------------------------------------------------------
Application.Range("c20").End(xlUp).Activate ' Arbitrarily pick "c20" as a starting point,
' then go to the top cell in the column.
varCurrentCell = ActiveCell.Address() ' Get the address of the new cell.
While Not IsNumeric(Range(varCurrentCell).Value) ' If the current cell is not
' numeric, then
Application.Range(varCurrentCell).Cells(2, 1).Activate ' Go down one cell,
varCurrentCell = ActiveCell.Address() ' Get the location of the new cell,
Wend ' and check the new cell.
varPreviousCell = ActiveCell.Address() ' Assign the first data cell to
' PreviousCell.
Application.Range(varPreviousCell).Cells(2, 1).Activate ' Go down one cell.
varCurrentCell = ActiveCell.Address() ' Assign the second data cell to
' CurrentCell.
Application.Range(varCurrentCell).Cells(2, 1).Activate ' Go down one cell.
varNextCell = ActiveCell.Address() ' Assign the third data cell to
' NextCell.
' -------------------------------------------------
' Do the following while NextCell is not empty:
' -------------------------------------------------
While Not IsEmpty(Range(varNextCell)) ' Check to see if the next cell contains data.
' -------------------------------------------------------------
' If CurrentCell is a peak, copy it to the cell five
' columns to the right. Copy the time information from
' column A to the left of the peak reading.
' -------------------------------------------------------------
fltPreviousValue = Range(varPreviousCell).Value ' Get the values of the previous,
fltCurrentValue = Range(varCurrentCell).Value ' current, and
fltNextValue = Range(varNextCell).Value ' next cells.
Range(varCurrentCell).Activate
If fltCurrentValue = RangeMin(ActiveCell.Offset(-2, 0), ActiveCell.Offset(2, 0)) And _
Range(varPreviousCell).Value > Range(varCurrentCell).Value And _
Range(varCurrentCell).Value <= Range(varNextCell).Value Then ' Check for peak.
Range(varCurrentCell).Select ' Select the value from the current cell
Selection.Copy (ActiveCell.Offset(0, 4)) ' and copy it to a cell 4 columns to
' the right.
Range(varCurrentCell).End(xlToLeft).Select ' Select the time value from column A and
Selection.Copy (ActiveCell.Offset(0, 7)) ' copy it to the cell next to the peak
' value.
End If
Application.Range(varCurrentCell).Activate ' Make sure that CurrentCell is the
' active cell.
' ---------------------------------------------------------------
' Reassign PreviousCell, CurrentCell, and NextCell to the
' next cell down.
' ---------------------------------------------------------------
varPreviousCell = ActiveCell.Address() ' Assign the current data cell
' to PreviousCell.
Application.Range(varPreviousCell).Cells(2, 1).Activate ' Go down one cell.
varCurrentCell = ActiveCell.Address() ' Assign the next data cell to
' CurrentCell.
Application.Range(varCurrentCell).Cells(2, 1).Activate ' Go down one cell.
varNextCell = ActiveCell.Address() ' Assign the third data cell to
' NextCell.
' --------------------
' End of the loop.
' --------------------
Wend
' --------------------------------------------------------------
' Move over to the column that has the peaks, and remove all
' the empty cells between the data.
' --------------------------------------------------------------
Application.Range(varCurrentCell).Cells(1, 5).Activate ' Move over 4 cells to the right.
Range(ActiveCell, "h11").Select ' Sort the peak data in descending
Selection.Sort key1:=ActiveCell, order1:=xlDescending ' order to move all the blank
' cells to the bottom.
Application.Range("g11").Activate ' Move to the top of the data.
Range(ActiveCell, ActiveCell.Offset(0, 1).End(xlDown)).Select ' Sort the resulting data in
Selection.Sort key1:=ActiveCell, order1:=xlAscending ' ascending order.
' ----------------------------------------------------------------
' Find the minimum, maximum, and average of the peaks, along
' with the standard deviation, printing this in an appropriate
' location.
' ----------------------------------------------------------------
Application.Range("g11").Activate
Range(ActiveCell, ActiveCell.End(xlDown)).Select
Range("g2").Value = Application.Max(Selection)
Range("g3").Value = Application.Average(Selection)
Range("g4").Value = Application.Min(Selection)
Range("g6").Value = Application.StDev(Selection)
Range("g7").Value = Application.AveDev(Selection)
' --------------------------------------------------------------
' Find the Strokes Per Minute (SPM) value, printing it in an
' appropriate location.
' --------------------------------------------------------------
Application.Range("h11").Activate
Range(ActiveCell, ActiveCell.End(xlDown)).Select
Range("h9").Value = Application.Count(Selection) / _
(Application.Max(Selection) - _
Application.Min(Selection)) / (24 * 60)
' ------------------------------
' End of FindNegPeaks Macro.
' ------------------------------
End Sub
' ----------------------------------------------------------------------------
' Title: RangeMin Function
'
' Author: Erik Oosterwal
' Date: August 22, 1997
'
' Description:
' This function returns the smallest value in a given range of values.
'
' Requirements & Restrictions:
' The values in the range must be single precision floating point.
' ----------------------------------------------------------------------------
Function RangeMin(StartCell As Variant, EndCell As Variant) As Single
' --------------------------------------------
' Delcare variables used in this function.
' --------------------------------------------
Dim varWorkCell As Variant
' --------------------------------------------------------------------------
' Set the initial value for RangeMin to be the largest number that will
' fit in a single precision float variable.
' --------------------------------------------------------------------------
RangeMin = 3.402823E+38
' ---------------------------------------------------------------------------
' Check each cell in the range to see if it contains numeric data. If it
' does, then compare it to the current value of RangeMin. If the current
' cell is smaller that RangeMin, then reassign the value in the current
' cell to RangeMin.
' ---------------------------------------------------------------------------
For Each varWorkCell In Range(StartCell, EndCell) ' Check each cell in the range.
If IsNumeric(varWorkCell.Value) Then ' Make sure the data is numeric.
If varWorkCell.Value < RangeMin Then ' Compare the data to RangeMax.
RangeMin = varWorkCell.Value ' Reassign the value to RangeMax.
End If
End If
Next ' Check the next cell in the range.
' ---------------------------------
' End of the RangeMin Function.
' ---------------------------------
End Function