TPPICORNELL
New Member
- Joined
- Jan 24, 2003
- Messages
- 4
DEAR ALL,
I HAVE A KIND OF vba macro about smoothing data on an excel worksheet!
I can submit it here, however I would like to know if there is a macro for smoothing data , not necessary based on savitzky-golay smoothing, but a good one!
The data have a continuous trend, positive evolution versus time, and a lot of noise!
I thank you for your help and any suggestion,
the macrosmoothing herewith could be improve, but if you test it, the general trend is very affected, dramatically!
data:
time temperature
0 27.4
0.2 27.3
0.4 27.5
0.6 27.8
0.8 28
1 28.1
1.2 28.4
1.4 28.4
1.6 28.5
1.8 28.5
2 28.6
2.2 28.6
2.4 28.7
2.6 28.8
2.8 28.9
3 28.8
3.2 29
3.4 30.4
3.6 30.3
3.8 29.9
4 29.8
4.2 29.6
4.4 29.8
4.6 29.8
4.8 29.8
5 29.7
5.2 29.5
5.4 29.6
5.6 29.6
5.8 29.5
6 29.4
6.2 29.5
6.4 29.6
6.6 29.6
6.8 29.6
7 29.7
7.2 29.7
7.4 29.8
7.6 29.6
7.8 29.9
8 30
8.2 29.9
8.4 29.8
8.6 29.9
8.8 29.8
9 29.7
9.2 29.8
9.4 29.8
9.6 30
9.8 29.9
10 30
10.2 29.8
10.4 29.7
10.6 30
10.8 29.9
11 29.9
11.2 29.8
11.4 30
11.6 29.9
11.8 29.8
12 30
12.2 30
12.4 30
12.6 29.9
12.8 29.8
13 30
13.2 30.1
13.4 30.1
13.6 30
13.8 30.1
14 30
14.2 30.2
14.4 30.1
14.6 30.2
14.8 30.1
15 30.1
15.2 30.1
15.4 30.2
15.6 30.1
15.8 30
16 30.2
16.2 30
16.4 30
16.6 30.1
16.8 30.1
17 30.1
17.2 30.3
17.4 30.1
17.6 30.1
17.8 30.2
18 30.1
18.2 30.3
18.4 30.2
18.6 30.3
18.8 30.2
19 30.3
19.2 30.3
19.4 30.2
19.6 30.3
19.8 30.3
20 30.4
20.2 30.2
20.4 30.4
20.6 30.3
20.8 30.3
21 30.1
21.2 30.3
21.4 32.3
21.6 31.1
21.8 30.9
22 31.1
22.2 31.1
22.4 30.8
22.6 30.8
22.8 30.7
23 30.9
23.2 30.8
23.4 30.8
23.6 30.7
23.8 30.9
24 30.8
24.2 30.7
24.4 30.7
24.6 30.8
24.8 30.9
25 30.9
25.2 30.9
25.4 30.9
25.6 31
25.8 30.9
26 30.7
26.2 30.7
26.4 30.6
26.6 30.9
26.8 30.9
27 30.9
27.2 30.8
27.4 30.9
27.6 30.7
27.8 30.8
28 30.9
28.2 30.7
28.4 30.7
28.6 30.9
28.8 30.7
29 31
29.2 30.9
29.4 30.7
29.6 30.7
29.8 30.7
30 30.7
30.2 30.8
30.4 30.9
30.6 30.8
30.8 30.9
31 30.8
31.2 30.7
31.4 30.8
31.6 30.7
31.8 30.7
32 30.8
32.2 30.9
32.4 30.9
32.6 31
32.8 30.9
33 30.9
33.2 30.8
33.4 31
33.6 30.9
33.8 30.9
34 30.9
34.2 30.7
34.4 30.7
34.6 30.8
34.8 30.8
35 30.7
35.2 30.9
35.4 30.8
35.6 31
35.8 30.8
36 30.8
36.2 30.8
36.4 30.8
36.6 30.8
36.8 30.8
37 30.9
37.2 30.8
37.4 30.9
37.6 31
37.8 30.8
38 30.9
38.2 30.7
38.4 30.7
38.6 31.1
38.8 30.8
39 30.8
39.2 30.9
39.4 30.9
39.6 30.9
39.8 31
40 30.9
40.2 30.7
40.4 30.9
40.6 30.8
40.8 30.7
41 30.7
41.2 30.9
41.4 30.7
41.6 30.8
41.8 30.8
42 30.8
42.2 30.7
42.4 30.9
42.6 30.7
42.8 30.8
43 30.9
43.2 30.8
43.4 30.8
43.6 30.9
43.8 30.9
44 30.9
44.2 30.8
44.4 30.8
44.6 30.9
44.8 30.8
macro:
Sub Makrosmoothing()
'
' Makrosmoothing Makro
' Makro am 27.08.2000 von ... aufgezeichnet
'
'Sub Smoothing()
Dim curValues() As Currency
Dim sngLowValue As Single
Dim sngHighValue As Single
Dim intIndex As Integer
Dim sngSmoothValues() As Single
Dim strSmoothValues As String
Dim strSmoothArray() As String
Dim strAddressParts() As String
Dim blnSameValues As Boolean
Dim strValue As String
Dim intLastRow As Integer
'Calls procedure to clear the smoothed data values leaving originals
ClearSmoothedData
'Set default smooth values for input box (you can change these)
strSmoothValues = "0.9, 0.7, 0.5, 0.3, 0.2, 0.1"
Range("B3").Select
'Requests multiple smooth values & puts them into string
strSmoothValues = InputBox("Enter the 'Peak' values to run in the form " & _
"'0.XXX' separated by commas.", "Multiple 'Peak' Values", _
strSmoothValues)
If strSmoothValues = "" Then
Exit Sub
End If
'Requests a default smooth value for subsequent iterations after prior ones _
are completed
strValue = "0.1"
strValue = InputBox("Default 'Peak' values to use if previously provided " & _
"values are not enough.", "Default 'Peak' Value", strValue)
'Removes spaces from the string
strSmoothValues = Replace(strSmoothValues, " ", "")
'Separates values by commas and puts values into an array
strSmoothArray = Split(strSmoothValues, ",")
'Creates an array of 100 elements & populates any higher indexed, _
non-populated element with 0.001
ReDim Preserve strSmoothArray(99)
For x = 0 To 99
If strSmoothArray(x) = "" Then
strSmoothArray(x) = strValue
End If
Next x
'For each element in the string array converts it to single & puts into another array
For x = 0 To UBound(strSmoothArray)
ReDim Preserve sngSmoothValues(x)
sngSmoothValues(x) = Val(strSmoothArray(x))
Next x
'Populates B3 value into lowest & highest for further testing
sngLowValue = Range("B3").Value
sngHighValue = Range("B3").Value
'Smoothes for as many smooth values provided
For x = 0 To UBound(sngSmoothValues)
'selects the first data cell in the column to smooth
Cells(3, ActiveCell.Column).Select
'Sets a variable that will be used to determine if 2 columns have identical values
blnSameValues = True
'Puts the smoothing value for this column in row 2
ActiveCell.Offset(-1, 1).Value = "Smooth-" & sngSmoothValues(x)
'Loop for all values
Do Until ActiveCell.Value = ""
'Check if doing 1st row
If ActiveCell.Row = 3 Then
'Just put current value into next column cell
ActiveCell.Offset(0, 1).Value = ActiveCell.Value
Else
'This if checks for ascending peaks (difference > smoothing value)
If ActiveCell.Value > ActiveCell.Offset(-1, 0).Value + sngSmoothValues(x) Then
'This if checks for ascending peaks & descending cliffs
'If ActiveCell.Value > ActiveCell.Offset(-1, 0).Value + sngSmoothValues(x) Or _
ActiveCell.Value < ActiveCell.Offset(-1, 0).Value - sngSmoothValues(x) Then
'Adds previous value to current value & divides by 2 and places in next column
ActiveCell.Offset(0, 1).Value = (ActiveCell.Offset(-1, 0).Value + _
ActiveCell.Value) / 2
Else
ActiveCell.Offset(0, 1).Value = ActiveCell.Value
End If
'Determine if current cell value is lower or higher than saved values
If ActiveCell.Value < sngLowValue Then
sngLowValue = ActiveCell.Value
ElseIf ActiveCell.Value > sngHighValue Then
sngHighValue = ActiveCell.Value
End If
End If
'Rounds next column value to 3 decimal points
ActiveCell.Offset(0, 1).Value = Round(ActiveCell.Offset(0, 1).Value, 3)
'If all the prior 2 column cells have the same value then
If blnSameValues = True Then
'Test for the current row's 2 cell values being different
If ActiveCell.Value <> ActiveCell.Offset(0, 1).Value Then
'If different, make the variable False & color cells blue
ActiveCell.Font.Color = vbBlue
ActiveCell.Offset(0, 1).Font.Color = vbBlue
blnSameValues = False
Else
'If the same, color cells black
ActiveCell.Font.Color = vbBlack
ActiveCell.Offset(0, 1).Font.Color = vbBlack
End If
End If
'Move to the next row
ActiveCell.Offset(1, 0).Select
Loop
'Check if all values in the 2 columns have been identical
If blnSameValues = True Then
'Provide message box & stop process
MsgBox "Values have become the same. It took " & _
x + 1 & " smoothing iterations.", vbInformation, _
"Smoothed to Same Values"
'Gets last data row for chart updating
intLastRow = ActiveCell.Offset(-1, 0).Row
'Save 3rd data value in 1st row to repopulate later
strValue = Range("C1").Value
'Determine last column
strAddressParts = Split(ActiveCell.Offset(0, 1).Address, "$")
'Select the last data column, copy it, & paste to column C
Columns(strAddressParts(1) & ":" & strAddressParts(1)).Select
Selection.Copy
Range("C1").Select
ActiveSheet.Paste
'Repopulate C1 value
ActiveCell.Value = strValue
'Select columns D though last data column and clear the contents
Columns("D:" & strAddressParts(1)).Select
Selection.ClearContents
Exit For
End If
'Move to next column in preparation for next iteration
ActiveCell.Offset(0, 1).Select
Next x
Range("B1").Select
'Round lowest value DOWN to integer
sngLowValue = Application.WorksheetFunction.RoundDown(sngLowValue, 0)
'Round highest value UP to integer
sngHighValue = Application.WorksheetFunction.RoundUp(sngHighValue, 0)
'Update Chart
Sheets("Chart").Select
ActiveSheet.ChartObjects("Chart 1").Activate
ActiveChart.ChartArea.Select
'Updates series ranges with last data row number
ActiveChart.SeriesCollection(1).Values = _
"='Kopie von Kopie von ACD3'!R3C2:R" & intLastRow & "C2"
ActiveChart.SeriesCollection(2).Values = _
"='Kopie von Kopie von ACD3'!R3C3:R" & intLastRow & "C3"
With ActiveChart
'Puts last row number into chart title
.ChartTitle.Characters.Text = Format(intLastRow, "#,##0") & " Data Values"
With .Axes(xlValue)
.Select
'Sets the y-axis scale for min & max to rounded values found in data
.MinimumScale = sngLowValue
.MaximumScale = sngHighValue
End With
End With
'Windows("completNew.xls").Activate
Range("A1").Select
Sheets("Kopie von Kopie von ACD3").Select
Range("B1").Select
End Sub
Private Sub ClearAllData()
'
' ClearData Macro
'
'
'
Range("A1").Select
ActiveCell.SpecialCells(xlLastCell).Select
Columns("A:" & Mid(ActiveCell.Address, InStr(1, ActiveCell.Address, "$") + 1, 1)).Select
Selection.ClearContents
Range("A1").Select
End Sub
Private Sub ClearSmoothedData()
'
' ClearData Macro
'
'
Dim strValue As String
Dim strColumns() As String
'
Range("A1").Select
strValue = Range("C1").Value
ActiveCell.SpecialCells(xlLastCell).Select
If ActiveCell.Column >= Range("C1").Column Then
strColumns = Split(ActiveCell.Address, "$")
Columns("C:" & strColumns(1)).Select
With Selection
.ClearContents
.Font.Color = vbBlack
End With
Range("C1").Value = strValue
Columns("B:B").Font.Color = vbBlack
End If
Range("A1").Select
End Sub
Private Sub FindDifferences()
Do Until ActiveCell.Value = ""
If ActiveCell.Value <> ActiveCell.Offset(0, 1).Value Then
Exit Sub
End If
ActiveCell.Offset(1, 0).Select
Loop
End Sub
Sub Makrosmoothing()
'
' Makrosmoothing Makro
' Makro am 27.08.2000 von ... aufgezeichnet
'
'Sub Smoothing()
Dim curValues() As Currency
Dim sngLowValue As Single
Dim sngHighValue As Single
Dim intIndex As Integer
Dim sngSmoothValues() As Single
Dim strSmoothValues As String
Dim strSmoothArray() As String
Dim strAddressParts() As String
Dim blnSameValues As Boolean
Dim strValue As String
Dim intLastRow As Integer
'Calls procedure to clear the smoothed data values leaving originals
ClearSmoothedData
'Set default smooth values for input box (you can change these)
strSmoothValues = "0.9, 0.7, 0.5, 0.3, 0.2, 0.1"
Range("B3").Select
'Requests multiple smooth values & puts them into string
strSmoothValues = InputBox("Enter the 'Peak' values to run in the form " & _
"'0.XXX' separated by commas.", "Multiple 'Peak' Values", _
strSmoothValues)
If strSmoothValues = "" Then
Exit Sub
End If
'Requests a default smooth value for subsequent iterations after prior ones _
are completed
strValue = "0.1"
strValue = InputBox("Default 'Peak' values to use if previously provided " & _
"values are not enough.", "Default 'Peak' Value", strValue)
'Removes spaces from the string
strSmoothValues = Replace(strSmoothValues, " ", "")
'Separates values by commas and puts values into an array
strSmoothArray = Split(strSmoothValues, ",")
'Creates an array of 100 elements & populates any higher indexed, _
non-populated element with 0.001
ReDim Preserve strSmoothArray(99)
For x = 0 To 99
If strSmoothArray(x) = "" Then
strSmoothArray(x) = strValue
End If
Next x
'For each element in the string array converts it to single & puts into another array
For x = 0 To UBound(strSmoothArray)
ReDim Preserve sngSmoothValues(x)
sngSmoothValues(x) = Val(strSmoothArray(x))
Next x
'Populates B3 value into lowest & highest for further testing
sngLowValue = Range("B3").Value
sngHighValue = Range("B3").Value
'Smoothes for as many smooth values provided
For x = 0 To UBound(sngSmoothValues)
'selects the first data cell in the column to smooth
Cells(3, ActiveCell.Column).Select
'Sets a variable that will be used to determine if 2 columns have identical values
blnSameValues = True
'Puts the smoothing value for this column in row 2
ActiveCell.Offset(-1, 1).Value = "Smooth-" & sngSmoothValues(x)
'Loop for all values
Do Until ActiveCell.Value = ""
'Check if doing 1st row
If ActiveCell.Row = 3 Then
'Just put current value into next column cell
ActiveCell.Offset(0, 1).Value = ActiveCell.Value
Else
'This if checks for ascending peaks (difference > smoothing value)
If ActiveCell.Value > ActiveCell.Offset(-1, 0).Value + sngSmoothValues(x) Then
'This if checks for ascending peaks & descending cliffs
'If ActiveCell.Value > ActiveCell.Offset(-1, 0).Value + sngSmoothValues(x) Or _
ActiveCell.Value < ActiveCell.Offset(-1, 0).Value - sngSmoothValues(x) Then
'Adds previous value to current value & divides by 2 and places in next column
ActiveCell.Offset(0, 1).Value = (ActiveCell.Offset(-1, 0).Value + _
ActiveCell.Value) / 2
Else
ActiveCell.Offset(0, 1).Value = ActiveCell.Value
End If
'Determine if current cell value is lower or higher than saved values
If ActiveCell.Value < sngLowValue Then
sngLowValue = ActiveCell.Value
ElseIf ActiveCell.Value > sngHighValue Then
sngHighValue = ActiveCell.Value
End If
End If
'Rounds next column value to 3 decimal points
ActiveCell.Offset(0, 1).Value = Round(ActiveCell.Offset(0, 1).Value, 3)
'If all the prior 2 column cells have the same value then
If blnSameValues = True Then
'Test for the current row's 2 cell values being different
If ActiveCell.Value <> ActiveCell.Offset(0, 1).Value Then
'If different, make the variable False & color cells blue
ActiveCell.Font.Color = vbBlue
ActiveCell.Offset(0, 1).Font.Color = vbBlue
blnSameValues = False
Else
'If the same, color cells black
ActiveCell.Font.Color = vbBlack
ActiveCell.Offset(0, 1).Font.Color = vbBlack
End If
End If
'Move to the next row
ActiveCell.Offset(1, 0).Select
Loop
'Check if all values in the 2 columns have been identical
If blnSameValues = True Then
'Provide message box & stop process
MsgBox "Values have become the same. It took " & _
x + 1 & " smoothing iterations.", vbInformation, _
"Smoothed to Same Values"
'Gets last data row for chart updating
intLastRow = ActiveCell.Offset(-1, 0).Row
'Save 3rd data value in 1st row to repopulate later
strValue = Range("C1").Value
'Determine last column
strAddressParts = Split(ActiveCell.Offset(0, 1).Address, "$")
'Select the last data column, copy it, & paste to column C
Columns(strAddressParts(1) & ":" & strAddressParts(1)).Select
Selection.Copy
Range("C1").Select
ActiveSheet.Paste
'Repopulate C1 value
ActiveCell.Value = strValue
'Select columns D though last data column and clear the contents
Columns("D:" & strAddressParts(1)).Select
Selection.ClearContents
Exit For
End If
'Move to next column in preparation for next iteration
ActiveCell.Offset(0, 1).Select
Next x
Range("B1").Select
'Round lowest value DOWN to integer
sngLowValue = Application.WorksheetFunction.RoundDown(sngLowValue, 0)
'Round highest value UP to integer
sngHighValue = Application.WorksheetFunction.RoundUp(sngHighValue, 0)
'Update Chart
Sheets("Chart").Select
ActiveSheet.ChartObjects("Chart 1").Activate
ActiveChart.ChartArea.Select
'Updates series ranges with last data row number
ActiveChart.SeriesCollection(1).Values = _
"='Kopie von Kopie von ACD3'!R3C2:R" & intLastRow & "C2"
ActiveChart.SeriesCollection(2).Values = _
"='Kopie von Kopie von ACD3'!R3C3:R" & intLastRow & "C3"
With ActiveChart
'Puts last row number into chart title
.ChartTitle.Characters.Text = Format(intLastRow, "#,##0") & " Data Values"
With .Axes(xlValue)
.Select
'Sets the y-axis scale for min & max to rounded values found in data
.MinimumScale = sngLowValue
.MaximumScale = sngHighValue
End With
End With
'Windows("completNew.xls").Activate
Range("A1").Select
Sheets("Kopie von Kopie von ACD3").Select
Range("B1").Select
End Sub
Private Sub ClearAllData()
'
' ClearData Macro
'
'
'
Range("A1").Select
ActiveCell.SpecialCells(xlLastCell).Select
Columns("A:" & Mid(ActiveCell.Address, InStr(1, ActiveCell.Address, "$") + 1, 1)).Select
Selection.ClearContents
Range("A1").Select
End Sub
Private Sub ClearSmoothedData()
'
' ClearData Macro
'
'
Dim strValue As String
Dim strColumns() As String
'
Range("A1").Select
strValue = Range("C1").Value
ActiveCell.SpecialCells(xlLastCell).Select
If ActiveCell.Column >= Range("C1").Column Then
strColumns = Split(ActiveCell.Address, "$")
Columns("C:" & strColumns(1)).Select
With Selection
.ClearContents
.Font.Color = vbBlack
End With
Range("C1").Value = strValue
Columns("B:B").Font.Color = vbBlack
End If
Range("A1").Select
End Sub
Private Sub FindDifferences()
Do Until ActiveCell.Value = ""
If ActiveCell.Value <> ActiveCell.Offset(0, 1).Value Then
Exit Sub
End If
ActiveCell.Offset(1, 0).Select
Loop
End Sub
I HAVE A KIND OF vba macro about smoothing data on an excel worksheet!
I can submit it here, however I would like to know if there is a macro for smoothing data , not necessary based on savitzky-golay smoothing, but a good one!
The data have a continuous trend, positive evolution versus time, and a lot of noise!
I thank you for your help and any suggestion,
the macrosmoothing herewith could be improve, but if you test it, the general trend is very affected, dramatically!
data:
time temperature
0 27.4
0.2 27.3
0.4 27.5
0.6 27.8
0.8 28
1 28.1
1.2 28.4
1.4 28.4
1.6 28.5
1.8 28.5
2 28.6
2.2 28.6
2.4 28.7
2.6 28.8
2.8 28.9
3 28.8
3.2 29
3.4 30.4
3.6 30.3
3.8 29.9
4 29.8
4.2 29.6
4.4 29.8
4.6 29.8
4.8 29.8
5 29.7
5.2 29.5
5.4 29.6
5.6 29.6
5.8 29.5
6 29.4
6.2 29.5
6.4 29.6
6.6 29.6
6.8 29.6
7 29.7
7.2 29.7
7.4 29.8
7.6 29.6
7.8 29.9
8 30
8.2 29.9
8.4 29.8
8.6 29.9
8.8 29.8
9 29.7
9.2 29.8
9.4 29.8
9.6 30
9.8 29.9
10 30
10.2 29.8
10.4 29.7
10.6 30
10.8 29.9
11 29.9
11.2 29.8
11.4 30
11.6 29.9
11.8 29.8
12 30
12.2 30
12.4 30
12.6 29.9
12.8 29.8
13 30
13.2 30.1
13.4 30.1
13.6 30
13.8 30.1
14 30
14.2 30.2
14.4 30.1
14.6 30.2
14.8 30.1
15 30.1
15.2 30.1
15.4 30.2
15.6 30.1
15.8 30
16 30.2
16.2 30
16.4 30
16.6 30.1
16.8 30.1
17 30.1
17.2 30.3
17.4 30.1
17.6 30.1
17.8 30.2
18 30.1
18.2 30.3
18.4 30.2
18.6 30.3
18.8 30.2
19 30.3
19.2 30.3
19.4 30.2
19.6 30.3
19.8 30.3
20 30.4
20.2 30.2
20.4 30.4
20.6 30.3
20.8 30.3
21 30.1
21.2 30.3
21.4 32.3
21.6 31.1
21.8 30.9
22 31.1
22.2 31.1
22.4 30.8
22.6 30.8
22.8 30.7
23 30.9
23.2 30.8
23.4 30.8
23.6 30.7
23.8 30.9
24 30.8
24.2 30.7
24.4 30.7
24.6 30.8
24.8 30.9
25 30.9
25.2 30.9
25.4 30.9
25.6 31
25.8 30.9
26 30.7
26.2 30.7
26.4 30.6
26.6 30.9
26.8 30.9
27 30.9
27.2 30.8
27.4 30.9
27.6 30.7
27.8 30.8
28 30.9
28.2 30.7
28.4 30.7
28.6 30.9
28.8 30.7
29 31
29.2 30.9
29.4 30.7
29.6 30.7
29.8 30.7
30 30.7
30.2 30.8
30.4 30.9
30.6 30.8
30.8 30.9
31 30.8
31.2 30.7
31.4 30.8
31.6 30.7
31.8 30.7
32 30.8
32.2 30.9
32.4 30.9
32.6 31
32.8 30.9
33 30.9
33.2 30.8
33.4 31
33.6 30.9
33.8 30.9
34 30.9
34.2 30.7
34.4 30.7
34.6 30.8
34.8 30.8
35 30.7
35.2 30.9
35.4 30.8
35.6 31
35.8 30.8
36 30.8
36.2 30.8
36.4 30.8
36.6 30.8
36.8 30.8
37 30.9
37.2 30.8
37.4 30.9
37.6 31
37.8 30.8
38 30.9
38.2 30.7
38.4 30.7
38.6 31.1
38.8 30.8
39 30.8
39.2 30.9
39.4 30.9
39.6 30.9
39.8 31
40 30.9
40.2 30.7
40.4 30.9
40.6 30.8
40.8 30.7
41 30.7
41.2 30.9
41.4 30.7
41.6 30.8
41.8 30.8
42 30.8
42.2 30.7
42.4 30.9
42.6 30.7
42.8 30.8
43 30.9
43.2 30.8
43.4 30.8
43.6 30.9
43.8 30.9
44 30.9
44.2 30.8
44.4 30.8
44.6 30.9
44.8 30.8
macro:
Sub Makrosmoothing()
'
' Makrosmoothing Makro
' Makro am 27.08.2000 von ... aufgezeichnet
'
'Sub Smoothing()
Dim curValues() As Currency
Dim sngLowValue As Single
Dim sngHighValue As Single
Dim intIndex As Integer
Dim sngSmoothValues() As Single
Dim strSmoothValues As String
Dim strSmoothArray() As String
Dim strAddressParts() As String
Dim blnSameValues As Boolean
Dim strValue As String
Dim intLastRow As Integer
'Calls procedure to clear the smoothed data values leaving originals
ClearSmoothedData
'Set default smooth values for input box (you can change these)
strSmoothValues = "0.9, 0.7, 0.5, 0.3, 0.2, 0.1"
Range("B3").Select
'Requests multiple smooth values & puts them into string
strSmoothValues = InputBox("Enter the 'Peak' values to run in the form " & _
"'0.XXX' separated by commas.", "Multiple 'Peak' Values", _
strSmoothValues)
If strSmoothValues = "" Then
Exit Sub
End If
'Requests a default smooth value for subsequent iterations after prior ones _
are completed
strValue = "0.1"
strValue = InputBox("Default 'Peak' values to use if previously provided " & _
"values are not enough.", "Default 'Peak' Value", strValue)
'Removes spaces from the string
strSmoothValues = Replace(strSmoothValues, " ", "")
'Separates values by commas and puts values into an array
strSmoothArray = Split(strSmoothValues, ",")
'Creates an array of 100 elements & populates any higher indexed, _
non-populated element with 0.001
ReDim Preserve strSmoothArray(99)
For x = 0 To 99
If strSmoothArray(x) = "" Then
strSmoothArray(x) = strValue
End If
Next x
'For each element in the string array converts it to single & puts into another array
For x = 0 To UBound(strSmoothArray)
ReDim Preserve sngSmoothValues(x)
sngSmoothValues(x) = Val(strSmoothArray(x))
Next x
'Populates B3 value into lowest & highest for further testing
sngLowValue = Range("B3").Value
sngHighValue = Range("B3").Value
'Smoothes for as many smooth values provided
For x = 0 To UBound(sngSmoothValues)
'selects the first data cell in the column to smooth
Cells(3, ActiveCell.Column).Select
'Sets a variable that will be used to determine if 2 columns have identical values
blnSameValues = True
'Puts the smoothing value for this column in row 2
ActiveCell.Offset(-1, 1).Value = "Smooth-" & sngSmoothValues(x)
'Loop for all values
Do Until ActiveCell.Value = ""
'Check if doing 1st row
If ActiveCell.Row = 3 Then
'Just put current value into next column cell
ActiveCell.Offset(0, 1).Value = ActiveCell.Value
Else
'This if checks for ascending peaks (difference > smoothing value)
If ActiveCell.Value > ActiveCell.Offset(-1, 0).Value + sngSmoothValues(x) Then
'This if checks for ascending peaks & descending cliffs
'If ActiveCell.Value > ActiveCell.Offset(-1, 0).Value + sngSmoothValues(x) Or _
ActiveCell.Value < ActiveCell.Offset(-1, 0).Value - sngSmoothValues(x) Then
'Adds previous value to current value & divides by 2 and places in next column
ActiveCell.Offset(0, 1).Value = (ActiveCell.Offset(-1, 0).Value + _
ActiveCell.Value) / 2
Else
ActiveCell.Offset(0, 1).Value = ActiveCell.Value
End If
'Determine if current cell value is lower or higher than saved values
If ActiveCell.Value < sngLowValue Then
sngLowValue = ActiveCell.Value
ElseIf ActiveCell.Value > sngHighValue Then
sngHighValue = ActiveCell.Value
End If
End If
'Rounds next column value to 3 decimal points
ActiveCell.Offset(0, 1).Value = Round(ActiveCell.Offset(0, 1).Value, 3)
'If all the prior 2 column cells have the same value then
If blnSameValues = True Then
'Test for the current row's 2 cell values being different
If ActiveCell.Value <> ActiveCell.Offset(0, 1).Value Then
'If different, make the variable False & color cells blue
ActiveCell.Font.Color = vbBlue
ActiveCell.Offset(0, 1).Font.Color = vbBlue
blnSameValues = False
Else
'If the same, color cells black
ActiveCell.Font.Color = vbBlack
ActiveCell.Offset(0, 1).Font.Color = vbBlack
End If
End If
'Move to the next row
ActiveCell.Offset(1, 0).Select
Loop
'Check if all values in the 2 columns have been identical
If blnSameValues = True Then
'Provide message box & stop process
MsgBox "Values have become the same. It took " & _
x + 1 & " smoothing iterations.", vbInformation, _
"Smoothed to Same Values"
'Gets last data row for chart updating
intLastRow = ActiveCell.Offset(-1, 0).Row
'Save 3rd data value in 1st row to repopulate later
strValue = Range("C1").Value
'Determine last column
strAddressParts = Split(ActiveCell.Offset(0, 1).Address, "$")
'Select the last data column, copy it, & paste to column C
Columns(strAddressParts(1) & ":" & strAddressParts(1)).Select
Selection.Copy
Range("C1").Select
ActiveSheet.Paste
'Repopulate C1 value
ActiveCell.Value = strValue
'Select columns D though last data column and clear the contents
Columns("D:" & strAddressParts(1)).Select
Selection.ClearContents
Exit For
End If
'Move to next column in preparation for next iteration
ActiveCell.Offset(0, 1).Select
Next x
Range("B1").Select
'Round lowest value DOWN to integer
sngLowValue = Application.WorksheetFunction.RoundDown(sngLowValue, 0)
'Round highest value UP to integer
sngHighValue = Application.WorksheetFunction.RoundUp(sngHighValue, 0)
'Update Chart
Sheets("Chart").Select
ActiveSheet.ChartObjects("Chart 1").Activate
ActiveChart.ChartArea.Select
'Updates series ranges with last data row number
ActiveChart.SeriesCollection(1).Values = _
"='Kopie von Kopie von ACD3'!R3C2:R" & intLastRow & "C2"
ActiveChart.SeriesCollection(2).Values = _
"='Kopie von Kopie von ACD3'!R3C3:R" & intLastRow & "C3"
With ActiveChart
'Puts last row number into chart title
.ChartTitle.Characters.Text = Format(intLastRow, "#,##0") & " Data Values"
With .Axes(xlValue)
.Select
'Sets the y-axis scale for min & max to rounded values found in data
.MinimumScale = sngLowValue
.MaximumScale = sngHighValue
End With
End With
'Windows("completNew.xls").Activate
Range("A1").Select
Sheets("Kopie von Kopie von ACD3").Select
Range("B1").Select
End Sub
Private Sub ClearAllData()
'
' ClearData Macro
'
'
'
Range("A1").Select
ActiveCell.SpecialCells(xlLastCell).Select
Columns("A:" & Mid(ActiveCell.Address, InStr(1, ActiveCell.Address, "$") + 1, 1)).Select
Selection.ClearContents
Range("A1").Select
End Sub
Private Sub ClearSmoothedData()
'
' ClearData Macro
'
'
Dim strValue As String
Dim strColumns() As String
'
Range("A1").Select
strValue = Range("C1").Value
ActiveCell.SpecialCells(xlLastCell).Select
If ActiveCell.Column >= Range("C1").Column Then
strColumns = Split(ActiveCell.Address, "$")
Columns("C:" & strColumns(1)).Select
With Selection
.ClearContents
.Font.Color = vbBlack
End With
Range("C1").Value = strValue
Columns("B:B").Font.Color = vbBlack
End If
Range("A1").Select
End Sub
Private Sub FindDifferences()
Do Until ActiveCell.Value = ""
If ActiveCell.Value <> ActiveCell.Offset(0, 1).Value Then
Exit Sub
End If
ActiveCell.Offset(1, 0).Select
Loop
End Sub
Sub Makrosmoothing()
'
' Makrosmoothing Makro
' Makro am 27.08.2000 von ... aufgezeichnet
'
'Sub Smoothing()
Dim curValues() As Currency
Dim sngLowValue As Single
Dim sngHighValue As Single
Dim intIndex As Integer
Dim sngSmoothValues() As Single
Dim strSmoothValues As String
Dim strSmoothArray() As String
Dim strAddressParts() As String
Dim blnSameValues As Boolean
Dim strValue As String
Dim intLastRow As Integer
'Calls procedure to clear the smoothed data values leaving originals
ClearSmoothedData
'Set default smooth values for input box (you can change these)
strSmoothValues = "0.9, 0.7, 0.5, 0.3, 0.2, 0.1"
Range("B3").Select
'Requests multiple smooth values & puts them into string
strSmoothValues = InputBox("Enter the 'Peak' values to run in the form " & _
"'0.XXX' separated by commas.", "Multiple 'Peak' Values", _
strSmoothValues)
If strSmoothValues = "" Then
Exit Sub
End If
'Requests a default smooth value for subsequent iterations after prior ones _
are completed
strValue = "0.1"
strValue = InputBox("Default 'Peak' values to use if previously provided " & _
"values are not enough.", "Default 'Peak' Value", strValue)
'Removes spaces from the string
strSmoothValues = Replace(strSmoothValues, " ", "")
'Separates values by commas and puts values into an array
strSmoothArray = Split(strSmoothValues, ",")
'Creates an array of 100 elements & populates any higher indexed, _
non-populated element with 0.001
ReDim Preserve strSmoothArray(99)
For x = 0 To 99
If strSmoothArray(x) = "" Then
strSmoothArray(x) = strValue
End If
Next x
'For each element in the string array converts it to single & puts into another array
For x = 0 To UBound(strSmoothArray)
ReDim Preserve sngSmoothValues(x)
sngSmoothValues(x) = Val(strSmoothArray(x))
Next x
'Populates B3 value into lowest & highest for further testing
sngLowValue = Range("B3").Value
sngHighValue = Range("B3").Value
'Smoothes for as many smooth values provided
For x = 0 To UBound(sngSmoothValues)
'selects the first data cell in the column to smooth
Cells(3, ActiveCell.Column).Select
'Sets a variable that will be used to determine if 2 columns have identical values
blnSameValues = True
'Puts the smoothing value for this column in row 2
ActiveCell.Offset(-1, 1).Value = "Smooth-" & sngSmoothValues(x)
'Loop for all values
Do Until ActiveCell.Value = ""
'Check if doing 1st row
If ActiveCell.Row = 3 Then
'Just put current value into next column cell
ActiveCell.Offset(0, 1).Value = ActiveCell.Value
Else
'This if checks for ascending peaks (difference > smoothing value)
If ActiveCell.Value > ActiveCell.Offset(-1, 0).Value + sngSmoothValues(x) Then
'This if checks for ascending peaks & descending cliffs
'If ActiveCell.Value > ActiveCell.Offset(-1, 0).Value + sngSmoothValues(x) Or _
ActiveCell.Value < ActiveCell.Offset(-1, 0).Value - sngSmoothValues(x) Then
'Adds previous value to current value & divides by 2 and places in next column
ActiveCell.Offset(0, 1).Value = (ActiveCell.Offset(-1, 0).Value + _
ActiveCell.Value) / 2
Else
ActiveCell.Offset(0, 1).Value = ActiveCell.Value
End If
'Determine if current cell value is lower or higher than saved values
If ActiveCell.Value < sngLowValue Then
sngLowValue = ActiveCell.Value
ElseIf ActiveCell.Value > sngHighValue Then
sngHighValue = ActiveCell.Value
End If
End If
'Rounds next column value to 3 decimal points
ActiveCell.Offset(0, 1).Value = Round(ActiveCell.Offset(0, 1).Value, 3)
'If all the prior 2 column cells have the same value then
If blnSameValues = True Then
'Test for the current row's 2 cell values being different
If ActiveCell.Value <> ActiveCell.Offset(0, 1).Value Then
'If different, make the variable False & color cells blue
ActiveCell.Font.Color = vbBlue
ActiveCell.Offset(0, 1).Font.Color = vbBlue
blnSameValues = False
Else
'If the same, color cells black
ActiveCell.Font.Color = vbBlack
ActiveCell.Offset(0, 1).Font.Color = vbBlack
End If
End If
'Move to the next row
ActiveCell.Offset(1, 0).Select
Loop
'Check if all values in the 2 columns have been identical
If blnSameValues = True Then
'Provide message box & stop process
MsgBox "Values have become the same. It took " & _
x + 1 & " smoothing iterations.", vbInformation, _
"Smoothed to Same Values"
'Gets last data row for chart updating
intLastRow = ActiveCell.Offset(-1, 0).Row
'Save 3rd data value in 1st row to repopulate later
strValue = Range("C1").Value
'Determine last column
strAddressParts = Split(ActiveCell.Offset(0, 1).Address, "$")
'Select the last data column, copy it, & paste to column C
Columns(strAddressParts(1) & ":" & strAddressParts(1)).Select
Selection.Copy
Range("C1").Select
ActiveSheet.Paste
'Repopulate C1 value
ActiveCell.Value = strValue
'Select columns D though last data column and clear the contents
Columns("D:" & strAddressParts(1)).Select
Selection.ClearContents
Exit For
End If
'Move to next column in preparation for next iteration
ActiveCell.Offset(0, 1).Select
Next x
Range("B1").Select
'Round lowest value DOWN to integer
sngLowValue = Application.WorksheetFunction.RoundDown(sngLowValue, 0)
'Round highest value UP to integer
sngHighValue = Application.WorksheetFunction.RoundUp(sngHighValue, 0)
'Update Chart
Sheets("Chart").Select
ActiveSheet.ChartObjects("Chart 1").Activate
ActiveChart.ChartArea.Select
'Updates series ranges with last data row number
ActiveChart.SeriesCollection(1).Values = _
"='Kopie von Kopie von ACD3'!R3C2:R" & intLastRow & "C2"
ActiveChart.SeriesCollection(2).Values = _
"='Kopie von Kopie von ACD3'!R3C3:R" & intLastRow & "C3"
With ActiveChart
'Puts last row number into chart title
.ChartTitle.Characters.Text = Format(intLastRow, "#,##0") & " Data Values"
With .Axes(xlValue)
.Select
'Sets the y-axis scale for min & max to rounded values found in data
.MinimumScale = sngLowValue
.MaximumScale = sngHighValue
End With
End With
'Windows("completNew.xls").Activate
Range("A1").Select
Sheets("Kopie von Kopie von ACD3").Select
Range("B1").Select
End Sub
Private Sub ClearAllData()
'
' ClearData Macro
'
'
'
Range("A1").Select
ActiveCell.SpecialCells(xlLastCell).Select
Columns("A:" & Mid(ActiveCell.Address, InStr(1, ActiveCell.Address, "$") + 1, 1)).Select
Selection.ClearContents
Range("A1").Select
End Sub
Private Sub ClearSmoothedData()
'
' ClearData Macro
'
'
Dim strValue As String
Dim strColumns() As String
'
Range("A1").Select
strValue = Range("C1").Value
ActiveCell.SpecialCells(xlLastCell).Select
If ActiveCell.Column >= Range("C1").Column Then
strColumns = Split(ActiveCell.Address, "$")
Columns("C:" & strColumns(1)).Select
With Selection
.ClearContents
.Font.Color = vbBlack
End With
Range("C1").Value = strValue
Columns("B:B").Font.Color = vbBlack
End If
Range("A1").Select
End Sub
Private Sub FindDifferences()
Do Until ActiveCell.Value = ""
If ActiveCell.Value <> ActiveCell.Offset(0, 1).Value Then
Exit Sub
End If
ActiveCell.Offset(1, 0).Select
Loop
End Sub
