A
akissinger
Here is some code i wrote to do stats on the data at the bottom. I
was wondering if anyone could tell me why the program will only alow
for 221 data points to be accurate. At 222 the algorithm does not
give the correct answer. In put the data into The input column J.
The data is sorted so that all the negs are on the bottem with and
then the algorithm is then run to give a regression of the data and is
output on the 3 or 4th row from the bottom. HELP
Sub Counting()
'Counting Macro
'Macro recorded 7/23/2007 by Andrew Kissinger
Dim g As Long
Dim x As Long
Dim z As Long
Dim t As Long
Dim temp As Long
Dim LastRow As Long
Dim B As Double
Dim Inter As Double
Dim Alpha As Double
Dim NumOfNeg As Long
'Dim Trim As Long
Dim e As Long
Dim ti As Long
Dim tx(1 To 1000, 1 To 1000) As Long
Dim numer As Double
Dim denom As Double
Dim beta As Double
Range("$A$2:I$" & temp + 10).ClearContents
LastRow = Cells(Application.Rows.Count, 10).End(xlUp).Row ' quack
x = 2
Do While Cells(x, 10).Value <> "" '|input the rank column
x = x + 1 '|
Loop '|
temp = x - 2
'MsgBox ("temp: " & temp) '| used to debug the number of items
Dim i As Long '| this loop is to trim the data
from online
For g = 2 To temp + 1
Cells(g, 2).Value = Left(Trim(Cells(g, 10).Value),
Len(Trim(Cells(g, 10).Value) - 1))
Cells(g, 9).Value = Abs(Left(Trim(Cells(g, 10).Value),
Len(Trim(Cells(g, 10).Value) - 1)))
'Cells(g, 7).Value = Right(Trim(Cells(g, 7).Value),
Len(Trim(Cells(g, 7).Value) - 1))
Next g
'For Trim = 2 To temp
' Cells(Trim, 7).Value = Left(Trim(Cells(Trim, 7).Value),
Len(Trim(Cells(Trim, 7).Value) - 1))
'Next Trim
Sort (LastRow) '| this sort is to sort the data in column A
NumOfNeg = CountNEG(temp)
For num = 2 To temp + 1
Cells(num, 1).Value = num - 1
Next num
Call SensorPoints2(temp, NumOfNeg)
i = 2
'MsgBox ("numofneg: " & NumofNeg)
Cells(1, 4).Value = 0
For ti = 2 To temp + 1
Cells(ti, 4).Value = Cells(ti - 1, 4).Value + ((temp + 1 - Cells(ti
- 1, 4).Value) / (temp + 2 - Cells(ti, 1).Value))
Next ti
'MsgBox ("here is temp: " & temp)
Do While Cells(i, 2).Value > 0
' Cells(i, 4).Value = 1 / (1 - Cells(i, 4).Value)
Cells(i, 3).Value = Log(Cells(i, 2).Value)
Cells(i, 5).Value = Log(-1 * Log(1 - ((Cells(i, 4).Value) - 0.3) /
(temp + 0.4)))
Cells(i, 6).Value = (Cells(i, 3).Value) ^ 2
Cells(i, 7).Value = (Cells(i, 5).Value) ^ 2
Cells(i, 8).Value = Cells(i, 3).Value * Cells(i, 5).Value
i = i + 1
' MsgBox (" this is cell 4930: " & Log(Cells(i, 1).Value))
Loop
'Call RunREG(temp, NumOfNeg)
Cells(temp + 3, 3).Value = 0
Cells(temp + 3, 5).Value = 0
Cells(temp + 3, 6).Value = 0
Cells(temp + 3, 7).Value = 0
Cells(temp + 3, 8).Value = 0
For B = 2 To temp + 1
Cells(temp + 4, 3).Value = Cells(temp + 4, 3).Value + Cells(B,
3).Value
Cells(temp + 4, 5).Value = Cells(temp + 4, 5).Value + Cells(B,
5).Value
Cells(temp + 4, 6).Value = Cells(temp + 4, 6).Value + Cells(B,
6).Value
Cells(temp + 4, 7).Value = Cells(temp + 4, 7).Value + Cells(B,
7).Value
Cells(temp + 4, 8).Value = Cells(temp + 4, 8).Value + Cells(B,
8).Value
Next B
Cells(1, 3).Value = "Ln(Ti)"
Cells(1, 4).Value = "F(Ti)"
Cells(1, 5).Value = "yi"
Cells(1, 6).Value = "(Ln(Ti)^2)"
Cells(1, 7).Value = "(yi^2)"
Cells(1, 8).Value = "Ln(Ti)*yi"
Cells(temp + 6, 1).Value = "Bata (Shape perameter)= "
Cells(temp + 7, 1).Value = "Alpha (Characteristic Life)= "
Dim lnti As Double
Dim fti As Double
Dim yi As Double
Dim lnTisqr As Double
Dim yisqr As Double
Dim lntiyi As Double
lnti = Cells(temp + 4, 3).Value
yi = Cells(temp + 4, 5).Value
lnTisqr = Cells(temp + 4, 6).Value
yisqr = Cells(temp + 4, 7).Value
lntiyi = Cells(temp + 4, 8).Value
numer = lntiyi - lnti * (yi / (temp - NumOfNeg))
denom = lnTisqr - ((lnti ^ 2) / (temp - NumOfNeg))
'MsgBox ("What is this cell: " & Cells(temp + 4, 3).Value)
'MsgBox ("What is this cell: " & Cells(temp + 4, 5).Value)
'MsgBox ("What is this cell: " & Cells(temp + 4, 6).Value)
'MsgBox ("What is this cell:numer " & numer)
'MsgBox ("What is this cell:denom " & denom)
beta = numer / denom
Cells(temp + 6, 3).Value = beta
'Inter = Cells(temp + 21, 2).Value
'MsgBox ("What is this cell: " & Inter & " " & B)
'Cells(temp + 24, 3).Value = Alpha
Alpha = (yi / (temp - NumOfNeg)) - (beta * (lnti / (temp -
NumOfNeg)))
Cells(temp + 7, 3).Value = Exp((-1 * Alpha) / beta)
End Sub
'| This is the sub function that is used to sort the data
'| the code for this was taken by the macro recorder
Sub Sort(temp)
Dim i As Long
Dim tempcellV As Long
Dim tempcellv1 As Long
Dim j As Long
Dim h As Long
Dim tempcell(1 To 1000, 1 To 1000) As Double
Dim g As Long
Dim k As Long
Dim t As Long
Dim m As Long
Dim testcell As Long
k = temp + 1
Sheet1.Activate
Sheet1.Range("A2:I1000").Select
Selection.Sort Key1:=Range("I2"), Key2:=Range("B2"),
Order1:=xlAscending, Order2:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom,
_
DataOption1:=xlSortTextAsNumbers
End Sub
Function RunREG(temp As Long, NumOfNeg As Long)
'| this is to run the regression tool pack for the data
Debug.Print "Range A Address: " & ActiveSheet.Range("$E$2:$E$" & temp
- NumOfNeg + 1).Address
Debug.Print "Range A Address: " & ActiveSheet.Range("$f$2:$f$" & temp
- NumOfNeg + 1).Address
Application.Run "'atpvbaen.xla'!Regress", ActiveSheet.Range("$e$2:$e
$"
& temp - NumOfNeg + 1), _
ActiveSheet.Range("$f$2:$f$" & temp - NumOfNeg + 1), False,
False, , ActiveSheet.Range( _
"$A$" & temp + 4 & ":$H$" & temp + 20), False, False, False,
False, , False
End Function
S
'| for counting the negitives to know what numbers to calc.
Function CountNEG(temp As Long) As Long
Dim i As Long
Dim x As Long
x = 0
For i = 2 To temp
If Cells(i, 2).Value < 0 Then
x = x + 1
End If
Next i
CountNEG = x
End Function
Sub Font()
'
' Macro5 Macro
' Macro recorded 8/6/2007 by Rex Little
'
'
Columns("A:I").Select
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
End Sub
Sub SensorPoints2(temp As Long, NumOfNeg As Long)
'| This will move the sensor points to the bottom of the data
'| after they have been ranked
Dim bLoop As Boolean
bLoop = False
Dim i As Long
Dim j As Long
Dim h As Long
Dim tempcell(1 To 1000, 1 To 1000) As Double
Dim tempcol(1 To 1000, 1 To 1000) As Double
Dim temp2 As Long
temp2 = temp
'MsgBox ("Temp2: " & temp2)
For i = 2 To temp
If Cells(i, 2).Value < 0 And i <= temp - NumOfNeg Then
bLoop = True
'if Cells(i, 1).Value < 0
For j = i To temp2
For h = 1 To 8
tempcol(j, h) = Cells(j, h).Value
Cells(j, h).Value = Cells(j + 1, h).Value
Cells(j + 1, h).Value = tempcol(j, h)
Next h
Next j
'Loop
End If
'MsgBox (" this is the next i: " & i)
Next i
If bLoop = True Then
Call SensorPoints2(temp, NumOfNeg)
Else
Call Font
End If
End Sub
*****************************************************
5411
4715
9964
12964
5538
8754
8415
9875
10512
6665
3023
9032
9486
21115
7929
10234
3018
3275
11069
11094
12827
1625
4985
7118
14943
9497
12323
5822
2792
3893
7719
6018
14291
1413
12060
7214
5434
1943
6155
5918
13161
6079
10318
9990
5072
7939
4570
13276
2069
7495
8411
8409
8953
10015
4986
3410
12121
8707
9926
5491
12481
6998
4777
8406
8793
8980
11405
1669
5424
13015
4759
12460
7468
4666
4970
7271
12724
12266
15402
12636
6483
42
5943
3939
3330
9150
-4429
-3277
-4382
-1184
-2665
-4865
-6455
-5114
-4088
-1390
-4590
-4723
-2749
-1996
-3537
-2875
-2105
-1843
-1978
-1183
-1113
-2598
-230
-1429
-3589
-90
-3469
-3634
-1570
-1496
-618
-1324
-3910
-227
-6219
-5770
-912
-3659
-1094
-3125
-4618
-2398
-2899
-2662
-657
-3525
-2762
-1213
-3199
-4939
-2625
-3623
-1287
-4170
-2708
-3717
-2685
-6362
-3053
-4690
-7143
-2519
-1430
-6151
-2761
-3014
-337
-1227
-2473
-4837
-2079
-3192
-1229
-3101
-1311
-3343
-1907
-6755
-5512
-6563
-974
-2311
-3604
-605
-4798
-4350
-2712
-1892
-3876
-4344
-2406
-4747
-7834
-23
-2892
-3753
-454
-6295
-8157
-3569
-3255
-1941
-551
-1227
-664
-4369
-1011
-3232
-2210
-4328
-2153
-3672
-184
-2730
-2789
-2991
-2032
-2003.4
-5284.8
-13474.8
-14965.2
-12142.8
-6310.8
-11815.2
-7956
-4521.6
-10436.4
-10629
-5214.6
-4638.6
-6188.4
-7495.2
-7068.6
-7135.2
-11341.8
-16683.88
was wondering if anyone could tell me why the program will only alow
for 221 data points to be accurate. At 222 the algorithm does not
give the correct answer. In put the data into The input column J.
The data is sorted so that all the negs are on the bottem with and
then the algorithm is then run to give a regression of the data and is
output on the 3 or 4th row from the bottom. HELP
Sub Counting()
'Counting Macro
'Macro recorded 7/23/2007 by Andrew Kissinger
Dim g As Long
Dim x As Long
Dim z As Long
Dim t As Long
Dim temp As Long
Dim LastRow As Long
Dim B As Double
Dim Inter As Double
Dim Alpha As Double
Dim NumOfNeg As Long
'Dim Trim As Long
Dim e As Long
Dim ti As Long
Dim tx(1 To 1000, 1 To 1000) As Long
Dim numer As Double
Dim denom As Double
Dim beta As Double
Range("$A$2:I$" & temp + 10).ClearContents
LastRow = Cells(Application.Rows.Count, 10).End(xlUp).Row ' quack
x = 2
Do While Cells(x, 10).Value <> "" '|input the rank column
x = x + 1 '|
Loop '|
temp = x - 2
'MsgBox ("temp: " & temp) '| used to debug the number of items
Dim i As Long '| this loop is to trim the data
from online
For g = 2 To temp + 1
Cells(g, 2).Value = Left(Trim(Cells(g, 10).Value),
Len(Trim(Cells(g, 10).Value) - 1))
Cells(g, 9).Value = Abs(Left(Trim(Cells(g, 10).Value),
Len(Trim(Cells(g, 10).Value) - 1)))
'Cells(g, 7).Value = Right(Trim(Cells(g, 7).Value),
Len(Trim(Cells(g, 7).Value) - 1))
Next g
'For Trim = 2 To temp
' Cells(Trim, 7).Value = Left(Trim(Cells(Trim, 7).Value),
Len(Trim(Cells(Trim, 7).Value) - 1))
'Next Trim
Sort (LastRow) '| this sort is to sort the data in column A
NumOfNeg = CountNEG(temp)
For num = 2 To temp + 1
Cells(num, 1).Value = num - 1
Next num
Call SensorPoints2(temp, NumOfNeg)
i = 2
'MsgBox ("numofneg: " & NumofNeg)
Cells(1, 4).Value = 0
For ti = 2 To temp + 1
Cells(ti, 4).Value = Cells(ti - 1, 4).Value + ((temp + 1 - Cells(ti
- 1, 4).Value) / (temp + 2 - Cells(ti, 1).Value))
Next ti
'MsgBox ("here is temp: " & temp)
Do While Cells(i, 2).Value > 0
' Cells(i, 4).Value = 1 / (1 - Cells(i, 4).Value)
Cells(i, 3).Value = Log(Cells(i, 2).Value)
Cells(i, 5).Value = Log(-1 * Log(1 - ((Cells(i, 4).Value) - 0.3) /
(temp + 0.4)))
Cells(i, 6).Value = (Cells(i, 3).Value) ^ 2
Cells(i, 7).Value = (Cells(i, 5).Value) ^ 2
Cells(i, 8).Value = Cells(i, 3).Value * Cells(i, 5).Value
i = i + 1
' MsgBox (" this is cell 4930: " & Log(Cells(i, 1).Value))
Loop
'Call RunREG(temp, NumOfNeg)
Cells(temp + 3, 3).Value = 0
Cells(temp + 3, 5).Value = 0
Cells(temp + 3, 6).Value = 0
Cells(temp + 3, 7).Value = 0
Cells(temp + 3, 8).Value = 0
For B = 2 To temp + 1
Cells(temp + 4, 3).Value = Cells(temp + 4, 3).Value + Cells(B,
3).Value
Cells(temp + 4, 5).Value = Cells(temp + 4, 5).Value + Cells(B,
5).Value
Cells(temp + 4, 6).Value = Cells(temp + 4, 6).Value + Cells(B,
6).Value
Cells(temp + 4, 7).Value = Cells(temp + 4, 7).Value + Cells(B,
7).Value
Cells(temp + 4, 8).Value = Cells(temp + 4, 8).Value + Cells(B,
8).Value
Next B
Cells(1, 3).Value = "Ln(Ti)"
Cells(1, 4).Value = "F(Ti)"
Cells(1, 5).Value = "yi"
Cells(1, 6).Value = "(Ln(Ti)^2)"
Cells(1, 7).Value = "(yi^2)"
Cells(1, 8).Value = "Ln(Ti)*yi"
Cells(temp + 6, 1).Value = "Bata (Shape perameter)= "
Cells(temp + 7, 1).Value = "Alpha (Characteristic Life)= "
Dim lnti As Double
Dim fti As Double
Dim yi As Double
Dim lnTisqr As Double
Dim yisqr As Double
Dim lntiyi As Double
lnti = Cells(temp + 4, 3).Value
yi = Cells(temp + 4, 5).Value
lnTisqr = Cells(temp + 4, 6).Value
yisqr = Cells(temp + 4, 7).Value
lntiyi = Cells(temp + 4, 8).Value
numer = lntiyi - lnti * (yi / (temp - NumOfNeg))
denom = lnTisqr - ((lnti ^ 2) / (temp - NumOfNeg))
'MsgBox ("What is this cell: " & Cells(temp + 4, 3).Value)
'MsgBox ("What is this cell: " & Cells(temp + 4, 5).Value)
'MsgBox ("What is this cell: " & Cells(temp + 4, 6).Value)
'MsgBox ("What is this cell:numer " & numer)
'MsgBox ("What is this cell:denom " & denom)
beta = numer / denom
Cells(temp + 6, 3).Value = beta
'Inter = Cells(temp + 21, 2).Value
'MsgBox ("What is this cell: " & Inter & " " & B)
'Cells(temp + 24, 3).Value = Alpha
Alpha = (yi / (temp - NumOfNeg)) - (beta * (lnti / (temp -
NumOfNeg)))
Cells(temp + 7, 3).Value = Exp((-1 * Alpha) / beta)
End Sub
'| This is the sub function that is used to sort the data
'| the code for this was taken by the macro recorder
Sub Sort(temp)
Dim i As Long
Dim tempcellV As Long
Dim tempcellv1 As Long
Dim j As Long
Dim h As Long
Dim tempcell(1 To 1000, 1 To 1000) As Double
Dim g As Long
Dim k As Long
Dim t As Long
Dim m As Long
Dim testcell As Long
k = temp + 1
Sheet1.Activate
Sheet1.Range("A2:I1000").Select
Selection.Sort Key1:=Range("I2"), Key2:=Range("B2"),
Order1:=xlAscending, Order2:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom,
_
DataOption1:=xlSortTextAsNumbers
End Sub
Function RunREG(temp As Long, NumOfNeg As Long)
'| this is to run the regression tool pack for the data
Debug.Print "Range A Address: " & ActiveSheet.Range("$E$2:$E$" & temp
- NumOfNeg + 1).Address
Debug.Print "Range A Address: " & ActiveSheet.Range("$f$2:$f$" & temp
- NumOfNeg + 1).Address
Application.Run "'atpvbaen.xla'!Regress", ActiveSheet.Range("$e$2:$e
$"
& temp - NumOfNeg + 1), _
ActiveSheet.Range("$f$2:$f$" & temp - NumOfNeg + 1), False,
False, , ActiveSheet.Range( _
"$A$" & temp + 4 & ":$H$" & temp + 20), False, False, False,
False, , False
End Function
S
'| for counting the negitives to know what numbers to calc.
Function CountNEG(temp As Long) As Long
Dim i As Long
Dim x As Long
x = 0
For i = 2 To temp
If Cells(i, 2).Value < 0 Then
x = x + 1
End If
Next i
CountNEG = x
End Function
Sub Font()
'
' Macro5 Macro
' Macro recorded 8/6/2007 by Rex Little
'
'
Columns("A:I").Select
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
End Sub
Sub SensorPoints2(temp As Long, NumOfNeg As Long)
'| This will move the sensor points to the bottom of the data
'| after they have been ranked
Dim bLoop As Boolean
bLoop = False
Dim i As Long
Dim j As Long
Dim h As Long
Dim tempcell(1 To 1000, 1 To 1000) As Double
Dim tempcol(1 To 1000, 1 To 1000) As Double
Dim temp2 As Long
temp2 = temp
'MsgBox ("Temp2: " & temp2)
For i = 2 To temp
If Cells(i, 2).Value < 0 And i <= temp - NumOfNeg Then
bLoop = True
'if Cells(i, 1).Value < 0
For j = i To temp2
For h = 1 To 8
tempcol(j, h) = Cells(j, h).Value
Cells(j, h).Value = Cells(j + 1, h).Value
Cells(j + 1, h).Value = tempcol(j, h)
Next h
Next j
'Loop
End If
'MsgBox (" this is the next i: " & i)
Next i
If bLoop = True Then
Call SensorPoints2(temp, NumOfNeg)
Else
Call Font
End If
End Sub
*****************************************************
5411
4715
9964
12964
5538
8754
8415
9875
10512
6665
3023
9032
9486
21115
7929
10234
3018
3275
11069
11094
12827
1625
4985
7118
14943
9497
12323
5822
2792
3893
7719
6018
14291
1413
12060
7214
5434
1943
6155
5918
13161
6079
10318
9990
5072
7939
4570
13276
2069
7495
8411
8409
8953
10015
4986
3410
12121
8707
9926
5491
12481
6998
4777
8406
8793
8980
11405
1669
5424
13015
4759
12460
7468
4666
4970
7271
12724
12266
15402
12636
6483
42
5943
3939
3330
9150
-4429
-3277
-4382
-1184
-2665
-4865
-6455
-5114
-4088
-1390
-4590
-4723
-2749
-1996
-3537
-2875
-2105
-1843
-1978
-1183
-1113
-2598
-230
-1429
-3589
-90
-3469
-3634
-1570
-1496
-618
-1324
-3910
-227
-6219
-5770
-912
-3659
-1094
-3125
-4618
-2398
-2899
-2662
-657
-3525
-2762
-1213
-3199
-4939
-2625
-3623
-1287
-4170
-2708
-3717
-2685
-6362
-3053
-4690
-7143
-2519
-1430
-6151
-2761
-3014
-337
-1227
-2473
-4837
-2079
-3192
-1229
-3101
-1311
-3343
-1907
-6755
-5512
-6563
-974
-2311
-3604
-605
-4798
-4350
-2712
-1892
-3876
-4344
-2406
-4747
-7834
-23
-2892
-3753
-454
-6295
-8157
-3569
-3255
-1941
-551
-1227
-664
-4369
-1011
-3232
-2210
-4328
-2153
-3672
-184
-2730
-2789
-2991
-2032
-2003.4
-5284.8
-13474.8
-14965.2
-12142.8
-6310.8
-11815.2
-7956
-4521.6
-10436.4
-10629
-5214.6
-4638.6
-6188.4
-7495.2
-7068.6
-7135.2
-11341.8
-16683.88