I'm trying to find and remove outliers from many columns of data, but it doesn't clear the cells that contain the outliers when I run the code. I tried just printing "colLength" within the first For loop, and that did nothing either. Advice on where I went wrong or how I might be able to fix it?
Sub Outliers()
Dim calc As Worksheet
Set calc = ThisWorkbook.Sheets("Sheet2")
Dim num As Double
Dim x As Integer
Dim y As Integer
Dim colLength As Integer
'Variables for upper fence, lower fence, first quartile, third quartile, and interquartile range
Dim upper As Double
Dim lower As Double
Dim q1 As Double
Dim q3 As Double
Dim interquartRange As Double
For y = 1 To y = 49
'Find last row of the column
colLength = calc.Cells(Rows.count, y).End(xlUp).Row
'Calculate first and third quartiles
q1 = Application.WorksheetFunction.Quartile(Range(Cells(2, y), Cells(colLength, y)), 1)
q3 = Application.WorksheetFunction.Quartile(Range(Cells(2, y), Cells(colLength, y)), 3)
interquartRange = q3 - q1
'Calculate upper and lower fences
upper = q3 + (1.5 * interquartRange)
lower = q1 - (1.5 * interquartRange)
For x = 2 To x = colLength
num = calc.Cells(x, y)
'Remove outliers
If num > upper Or num < lower Then
Range(calc.Cells(x, y)).ClearContents
End If
Next x
Next y
End Sub
For y = 1 To y = 49 should be For y = 1 To 49. Similarly For x = 2 To x = colLength should be For x = 2 To colLength
Try this in a new module and you will see and understand the difference ;)
Dim Y As Long
Sub SampleA()
For Y = 1 To Y = 49
Debug.Print Y
Next Y
End Sub
Sub SampleB()
For Y = 1 To 49
Debug.Print Y
Next Y
End Sub
Related
I don't understand why 2 of my codes have overflow error
Sub varr3_1()
Dim x As Single
Dim y As Single
For x = 1 To 2 Step 0.2
y = Sqr((x - 1) / (x + 1))
Debug.Print x, y
Next x
End Sub
Sub varr3_3()
Dim x As Single
Dim z As Double
For x = 3 To 8 Step 0.9
z = 2
While (z > 1)
z = Log(x) + Tan(2 * x)
Debug.Print z
Wend
Next x
End Sub
I tried to change Single to Integer and so on but there is still a problem
The first sub Var3_1() works fine for me.
The second sub gets stuck in an endless loop on the second iteration of x. The value of z = 19.86... which will always be greater than 1 so the While/Wend loop never exits thus resulting in an eventual overflow.
I have this code below, and I'm getting an overflow error at the line:
s = s + (x Mod 10) [first line in the Do Loop]
Why? I declared x and s to be of type Double. Adding two doubles, why is this not working?
Thanks for your help.
Public Sub bidon1()
Dim i As Double, x As Double, s As Double, k As Byte, h As Byte
Dim y(1 To 6) As Double
For i = 1 To 1000000
x = i ^ 3
Do
s = s + (x Mod 10)
x = x \ 10
Loop Until x = 0
If s = x Then
k = k + 1
y(k) = x
If y(6) > 0 Then
For h = 1 To 6
Debug.Print y(h)
Next
Exit Sub
End If
End If
Next
End Sub
The problem is that the VBA mod operator coerces its arguments to be integers (if they are not already so). It is this implicit coercion which is causing the overflow. See this question: Mod with Doubles
On Edit:
Based on your comments, you want to be able to add together the digits in a largish integer. The following function might help:
Function DigitSum(num As Variant) As Long
'Takes a variant which represents an integer type
'such as Integer, Long or Decimal
'and returns the sum of its digits
Dim sum As Long, i As Long, s As String
s = CStr(num)
For i = 1 To Len(s)
sum = sum + Val(Mid(s, i, 1))
Next i
DigitSum = sum
End Function
The following test sub shows how it can be used to correctly get the sum of the digits in 999999^3:
Sub test()
Dim x As Variant, y As Variant
Debug.Print "Naive approach: " & DigitSum(999999 ^ 3)
y = CDec(999999)
x = y * y * y
Debug.Print "CDec approach: " & DigitSum(x)
End Sub
Output:
Naive approach: 63
CDec approach: 108
Since 999999^3 = 999997000002999999, only the second result is accurate. The first result is only the sum of the digits in the string representation of the double 999999^3 = 9.99997000003E+17
this function interpolates/extrapolates a table of known x,y
For example,
x y
1 10
2 15
3 20
Linterp(A1:B3, -1) = 0
However, this code can only do two adjacent arrays.
I would like to modify this code so that I can
select two separate arrays, for example N106:N109,P106:P109.
How can I make this adjustment in this code?
Function Linterp(r As Range, x As Double) As Double
' linear interpolator / extrapolator
' R is a two-column range containing known x, known y
Dim lR As Long, l1 As Long, l2 As Long
Dim nR As Long
'If x = 1.5 Then Stop
nR = r.Rows.Count
If nR < 2 Then Exit Function
If x < r(1, 1) Then ' x < xmin, extrapolate
l1 = 1: l2 = 2: GoTo Interp
ElseIf x > r(nR, 1) Then ' x > xmax, extrapolate
l1 = nR - 1: l2 = nR: GoTo Interp
Else
' a binary search would be better here
For lR = 1 To nR
If r(lR, 1) = x Then ' x is exact from table
Linterp = r(lR, 2)
Exit Function
ElseIf r(lR, 1) > x Then ' x is between tabulated values, interpolate
l1 = lR: l2 = lR - 1: GoTo Interp
End If
Next
End If
Interp:
Linterp = r(l1, 2) _
+ (r(l2, 2) - r(l1, 2)) _
* (x - r(l1, 1)) _
/ (r(l2, 1) - r(l1, 1))
End Function
one very simple way is having the function accepting two ranges in input, one for X values (say rX) and one for Y ones (say rY), and then changing every occurrence of r(foo,1) to rX(foo) and r(foo,2) to rY(foo)
like follows
Option Explicit
Function Linterp2(rX As Range, rY As Range, x As Double) As Double
' linear interpolator / extrapolator
' R is a two-column range containing known x, known y
Dim lR As Long, l1 As Long, l2 As Long
Dim nR As Long
'If x = 1.5 Then Stop
nR = rX.Rows.Count
If nR < 2 Then Exit Function
If x < rX(1) Then ' x < xmin, extrapolate
l1 = 1: l2 = 2: GoTo Interp
ElseIf x > rX(nR) Then ' x > xmax, extrapolate
l1 = nR - 1: l2 = nR: GoTo Interp
Else
' a binary search would be better here
For lR = 1 To nR
If rX(lR) = x Then ' x is exact from table
Linterp2 = rY(lR)
Exit Function
ElseIf rX(lR) > x Then ' x is between tabulated values, interpolate
l1 = lR: l2 = lR - 1: GoTo Interp
End If
Next
End If
Interp:
Linterp2 = rY(l1) _
+ (rY(l2) - rY(l1)) _
* (x - rX(l1)) _
/ (rX(l2) - rX(l1))
End Function
but you must implement code to check for consistency of the two ranges, like being both of one column each and with the same number of rows
use this function :
Public Function lineare_iterpolation(x As Variant, x1 As Variant, x2 As Variant, y1 As Variant, y2 As Variant) As Variant
If x = x1 Then
lineare_iterpolation = y1
Exit Function
End If
If x = x2 Then
lineare_iterpolation = y2
Exit Function
End If
lineare_iterpolation = y1 + (x - x1) * (y2 - y1) / (x2 - x1)
Exit Function
End Function
First off, here is what I have so far:
Option Explicit
Dim y As Variant
Dim yforx As Variant
Dim yfork As Variant
Dim ynew As Variant
Dim ymin As Variant
Dim x As Variant
Dim xmin As Variant
Dim k As Variant
Dim kmin As Variant
Dim s As Variant
Dim Z As Variant
Dim Track As Variant
Sub PracticeProgram()
'Selects the right sheet
Sheets("PracticeProgram").Select
'y = k ^ 2 * (x ^ 2 + 2 * x * k - 6) / (x + k) ^ 2
'these are the bounds we are stepping through
Track = 0
x = 1
xmin = 1
k = 1
kmin = 1
y = 100000000
yforx = 100000
yfork = 1000000000
Do
y = 100000000
For x = 0 To 1000 Step 0.1
ynew = kmin ^ 2 * (x ^ 2 + 2 * x * kmin - 6) / (x + kmin) ^ 2
'This checks the new y-value against an absurdly high y-value we know is wrong. if it is less than this y-value, we keep the x-value that corresponds with it.
If ynew < y Then
xmin = x
y = ynew
yforx = y
xmin = Application.Evaluate("=Round(" & xmin & ", 3)")
Else
End If
Next
MsgBox (yforx)
For k = 0 To 1000 Step 0.1
y = k ^ 2 * (xmin ^ 2 + 2 * xmin * k - 6) / (xmin + k) ^ 2
If ynew < y Then
kmin = k
y = ynew
yfork = y
kmin = Application.Evaluate("=Round(" & kmin & ",3)")
Else
End If
Next
MsgBox (yfork)
Loop Until (Abs(yforx - yfork) < 10)
End Sub
This program is supposed to find the values of x and k in order to minimize the value of y. This is a practice for a much more complicated program that will use this same concept. In my actual program y, k, and x will all be greater than zero no matter what, but since it was hard to think of a simple equation whose results would be in the shape of a parabola opening up, I decided to allow negative answers for this practice program.
Basically, it should bounce back and forth between the equations finding the ideal values for x and k until finally it has a minimal answer for y using ideal answers for both x and k. I'm not sure what the actual answer is, so I'm letting it stop within a range of 10. If it works, I'll make it smaller, but I don't want the program going for forever, just in case.
MY PROBLEM: I keep getting overflow errors! I'm trying to round the values for xmin and kmin to three figures after the decimal, but it doesn't seem to be helping. Am I using them wrong? Can someone help me get this program working?
You're doing a division by zero. xmin = 0, k = 0, (xmin + k) ^ 2 = 0. (I'm not sure why it isn't reporting division by zero.)
A suggestion: use the Locals pane to see the value of local variables. You can also use the Watch pane to see the value of expressions you want to monitor.
this application for computing the gcd by using extended euclidean but it give me just the value for first iteration but i need the final values of x2 y2 a
Private Sub Button1_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button1.Click
Dim x1 As Integer
Dim x2 As Integer
Dim y1 As Integer
Dim y2 As Integer
Dim x As Integer
Dim y As Integer
Dim a As Integer
Dim temp As Integer
a = CInt(TextBox1.Text)
Dim b As Integer
b = CInt(TextBox2.Text)
Dim q As Integer
x1 = 0
y1 = 1
x2 = 1
y2 = 0
If b > a Then
temp = a
a = b
b = temp
End If
Do While (b <> 0)
q = Math.Floor(a / b)
a = b
b = a Mod b
x = x2 - q * x1
x2 = x1
y = y2 - q * y1
y2 = y1
x1 = x
y1 = y
Loop
MessageBox.Show("the final value of x2 is " & CStr(x2) & "the final value of y2 is " & CStr(y2) & "the GCD is " & CStr(a), " the result ")
End Sub
Here's your problem:
a = b
b = a Mod b
In the second statement, a is already equal to b, so a Mod b is always zero.
'Euclid's algorithm
'code assumes that you are looking for the GCD of the
'values entered into TextBox1 and TextBox2
Dim dividend As Long
Dim divisor As Long
Dim quotient As Long
Dim remainder As Long
If Long.TryParse(TextBox1.Text, dividend) Then
If Long.TryParse(TextBox2.Text, divisor) Then
'place in correct order
quotient = Math.Max(dividend, divisor) 'determine max number
remainder = Math.Min(dividend, divisor) 'determine min number
dividend = quotient 'max is dividend
divisor = remainder 'min is divisor
Do
quotient = Math.DivRem(dividend, divisor, remainder) 'do the division
'set up for next divide
dividend = divisor 'dividend is previous divisor. if remainder is zero then dividend = GCD
divisor = remainder 'divisor is previous remainder
Loop While remainder <> 0 'loop until the remainder is zero
Label1.Text = dividend.ToString("n0")
End If
End If