Long Datatype Overflow - excel

I am trying to do some prime factorisation with my VBA excel and I am hitting the limit of the long data type -
Runtime Error 6 Overflow
Is there any way to get around this and still stay within VBA? I am aware that the obvious one would be to use another more appropriate programming language.
Lance's solution works in so far that I am able to get the big numbers into the variables now. However, when I try to apply the MOD function - bignumber MOD 2, for example - it still fails with error message
Runtime Error 6 Overflow

You can use Decimal data type. Quick hint from google: http://www.ozgrid.com/VBA/convert-to-decimal.htm

This is my Decimals.cls (VB6):
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
Persistable = 0 'NotPersistable
DataBindingBehavior = 0 'vbNone
DataSourceBehavior = 0 'vbNone
MTSTransactionMode = 0 'NotAnMTSObject
END
Attribute VB_Name = "Decimals"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Attribute VB_Ext_KEY = "SavedWithClassBuilder6" ,"Yes"
Attribute VB_Ext_KEY = "Top_Level" ,"Yes"
Option Explicit
'local variable(s) to hold property value(s)
Private mvarDec As Variant 'local copy
Public Property Let Dec(ByVal vData As Variant)
'used when assigning a value to the property, on the left side of an assignment.
'Syntax: X.Dec = 5
mvarDec = CDec(vData)
End Property
Public Property Get Dec() As Variant
Attribute Dec.VB_UserMemId = 0
'used when retrieving value of a property, on the right side of an assignment.
'Syntax: Debug.Print X.Dec
Dec = CDec(mvarDec)
End Property
and this is a testing program. The class has been setup so that you don't have to qualify with .Dec() on get and let.
Dim dec1 As New Std.Decimals
Dim dec2 As New Std.Decimals
Dim dec3 As New Std.Decimals
Dim modulus As New Std.Decimals
Sub main()
dec1 = "1000.000000001"
dec2 = "1000.00000000000001"
dec3 = dec1 + dec2
Debug.Print dec1
Debug.Print dec2
Debug.Print dec3
Debug.Print dec3 * dec3
Debug.Print dec3 / 10
Debug.Print dec3 / 100
Debug.Print Sqr(dec3)
modulus = dec1 - Int(dec1 / dec2) * dec2
Debug.Print modulus
End Sub
and sample run
1000.000000001
1000.00000000000001
2000.00000000100001
4000000.000004000040000001
200.000000000100001
20.0000000000100001
44.721359550007
0.00000000099999
1000.000000001
1000.00000000000001
2000.00000000100001
4000000.000004000040000001
200.000000000100001
20.0000000000100001
44.721359550007
0.00000000099999

Here is my "big multiply" routine for multiplying arbitrarily large numbers (eg 100 characters long). It works by splitting the input numbers, which are strings, into chunks of 7 digits (because then it can cross multiply them and store the results in Doubles).
eg bigmultiply("1934567803945969696433","4483838382211678") = 8674289372323895422678848864807544574
Function BigMultiply(ByVal s1 As String, ByVal s2 As String) As String
Dim x As Long
x = 7
Dim n1 As Long, n2 As Long, n As Long
n1 = Int(Len(s1) / x + 0.999999)
n2 = Int(Len(s2) / x + 0.999999)
n = n1 + n2
Dim i As Long, j As Long
ReDim za1(n1) As Double
i = Len(s1) Mod x
If i = 0 Then i = x
za1(1) = Left(s1, i)
i = i + 1
For j = 2 To n1
za1(j) = Mid(s1, i, x)
i = i + x
Next j
ReDim za2(n2) As Double
i = Len(s2) Mod x
If i = 0 Then i = x
za2(1) = Left(s2, i)
i = i + 1
For j = 2 To n2
za2(j) = Mid(s2, i, x)
i = i + x
Next j
ReDim z(n) As Double
Dim u1 As Long, u2 As Long
Dim e As String
e = String(x, "0")
For u1 = 1 To n1
i = u1
For u2 = 1 To n2
i = i + 1
z(i) = z(i) + za1(u1) * za2(u2)
Next u2
Next u1
Dim s As String, y As Double, w As Double, m As Long
m = n * x
s = String(m, "0")
y = 10 ^ x
For i = n To 1 Step -1
w = Int(z(i) / y)
Mid(s, i * x - x + 1, x) = Format(z(i) - w * y, e)
z(i - 1) = z(i - 1) + w
Next i
'truncate leading zeros
For i = 1 To m
If Mid$(s, i, 1) <> "0" Then Exit For
Next i
If i > m Then
BigMultiply = ""
Else
BigMultiply = Mid$(s, i)
End If
End Function

MOD is trying to convert your DECIMAL type to LONG before operating on it. You may need to write your own MOD function for the DECIMAL type. You might try this:
r = A - Int(A / B) * B
where A & B are DECIMAL subtype of VARIANT variables, and r might have to be that large also (depending on your needs), though I only tested on a long.

Related

Getting a specific value from excel chart with vba

I am trying to get a specific value from an excel chart. This is the code which creates my chart (I created a reversed binomial distribution plot) :
Dim lim As String
Dim N As Long
N = Range("C4").Value
Dim x, s, p As Double
x = Range("C6") 'event number
s = Range("C5") 'sample size
Dim g() As Long
Dim h() As Double
Dim k() As Double
Dim prob() As Double
ReDim g(N)
ReDim prob(N)
ReDim h(N)
ReDim k(N)
For i = 1 To N
g(i) = i
h(i) = i / N
k(i) = 1 - h(i)
prob(i) = WorksheetFunction.BinomDist(x, s, h(i), False) * 100
End If
And here is chart:
I need the point where y is 0 on distribution curve second time.
At the end of your For Loop, you could check if prob(i) = 0 And Prob(i-1) > 0, and save the index of this point. It's "too" simple, yet if this is just for this kind of distribution, it do the job :
Dim targetIndex As Integer
For i = 1 To N
g(i) = i
h(i) = i / N
k(i) = 1 - h(i)
prob(i) = WorksheetFunction.BinomDist(x, s, h(i), False) * 100
If i > 1 Then 'check if this is not the first point
If prob(i) = 0 And prob(i-1) <> 0 Then targetIndex = i
End If
Next
'// Now your point is the couple (targetIndex, prob(targetIndex))

Find if the number is Prime or show the prime factors using excel formula?

I have of integers in Col A and in col B i want to show result 'Prime' if it doesn't have further factors for the number itself. This goes like this if the number for example is 37 result will be 'Prime' and if its 44 then result will be 2x2x11. How can i do this using excel formula? Screen shot :
Disclaimer: code below is ported from this very useful VB.NET example
Option Explicit
Sub Test()
Debug.Print FindFactors(2)
Debug.Print FindFactors(3)
Debug.Print FindFactors(11)
Debug.Print FindFactors(12)
Debug.Print FindFactors(13)
Debug.Print FindFactors(16)
Debug.Print FindFactors(17)
Debug.Print FindFactors(24)
Debug.Print FindFactors(25)
Debug.Print FindFactors(11234)
Debug.Print FindFactors(67894)
End Sub
Function FindFactors(lngNumber As Long) As String
Dim collFactors As Collection
Dim lngFactor As Long
Dim lngCounter As Long
Dim strFactors As String
Dim strFactor As String
Set collFactors = New Collection
' Take out the 2s.
Do While (lngNumber Mod 2 = 0)
collFactors.Add 2
lngNumber = lngNumber / 2
Loop
' Take out other primes.
lngFactor = 3
Do While (lngFactor * lngFactor <= lngNumber)
If (lngNumber Mod lngFactor = 0) Then
' This is a factor.
collFactors.Add lngFactor
lngNumber = lngNumber / lngFactor
Else
' Go to the next odd number.
lngFactor = lngFactor + 2
End If
Loop
' If num is not 1, then whatever is left is prime.
If lngNumber > 1 Then
collFactors.Add lngNumber
End If
' make a string out of collection
strFactors = ""
If collFactors.Count = 1 Then
strFactors = "Prime"
Else
For lngCounter = 1 To collFactors.Count
strFactors = strFactors & collFactors(lngCounter)
If lngCounter < collFactors.Count Then
strFactors = strFactors & "x"
End If
Next lngCounter
End If
FindFactors = strFactors
End Function
Gives an output of:
Prime
Prime
Prime
2x2x3
Prime
2x2x2x2
Prime
2x2x2x3
5x5
2x41x137
2x83x409
Can be used in a worksheet:
Here is a somewhat straightforward recursive version. It is based on the idea that once you identify a factor you divide the number by that factor and then turn your attention to factoring the rest.
Function Factor(ByVal n As Long, Optional FirstTrial As Long = 2) As String
Dim i As Long
Dim t As Long
Dim limit As Long
Dim rest As String
Dim s As String
If n = 1 Then
Factor = n
Exit Function
End If
limit = Int(Sqr(n))
t = FirstTrial
Do While t <= limit
If n Mod t = 0 Then
rest = Factor(n / t, t)
If rest <> "1" Then
s = t & "x" & rest
End If
Factor = s
Exit Function
Else
If t = 2 Then t = 3 Else t = t + 2
End If
Loop
'if we get here:
Factor = n
End Function
Function PrimeOrFactor(n As Long) As String
Dim s As String
s = Factor(n)
If n = 1 Then
PrimeOrFactor = "Neither"
ElseIf (s) = Trim(n) Then
PrimeOrFactor = "Prime"
Else
PrimeOrFactor = s
End If
End Function
Tested like:
Sub test()
Dim i As Long
For i = 1 To 20
Cells(i, 1) = i
Cells(i, 2) = PrimeOrFactor(i)
Next i
End Sub
Output:
Using LET and dynamic arrays allows for the following without VBA.
=LET(x, SEQUENCE(A1),
factors, FILTER(x, MOD(A1,x) = 0),
factorMatrix, 1 * (MOD(factors, TRANSPOSE(factors)) = 0),
primeFactors, FILTER(factors, MMULT(factorMatrix, factors ^ 0) = 2),
primeFactorList, IF(MOD(A1, primeFactors ^ SEQUENCE(1, 20)) = 0, primeFactors, ""),
factorProduct, TEXTJOIN("x",, primeFactorList),
IF(A1 = 1, "Neither", IF(factorProduct=A1&"","Prime",factorProduct)))
It works for numbers up to 2^20.
A slight modification to the excellent code of John Coleman above, using Mod with Doubles included below, will allow factoring integers up to Excel's 15 digit limit. Numbers with large factors may be noticeably slower. For example, 562,951,983,465,953 factored correctly as 16,777,259 x 33,554,467 in about 5 seconds on a Core i3.
Function Factor(ByVal n As Double, Optional FirstTrial As Double = 2) As String 'Changed
Dim i As Long
Dim t As Double 'Changed
Dim limit As Long
Dim rest As String
Dim s As String
If n = 1 Then
Factor = n
Exit Function
End If
limit = Int(Sqr(n))
t = FirstTrial
Do While t <= limit
If FMod(t, n) = 0 Then 'Changed
.
.
.
Public Function FMod(a As Double, b As Double) As Double
FMod = a - Fix(a / b) * b
'http://en.wikipedia.org/wiki/Machine_epsilon
'Unfortunately, this function can only be accurate when `a / b` is outside [-2.22E-16,+2.22E-16]
'Without this correction, FMod(.66, .06) = 5.55111512312578E-17 when it should be 0
If FMod >= -2 ^ -52 And FMod <= 2 ^ -52 Then '+/- 2.22E-16
FMod = 0
End If
End Function

How to find FFT in Excel without using Fourier Analysis function?

I am trying to write an FFT application in Excel that claculates frequencies, amplitude and phase. I know how to use the in-built function but the data I am trying to analyse has 32,795 points, more than the maximum 4096 for the in-buit function.
Does anyone know how I can either (1) Increase the maximum number of data inputs? (2) Write my own macro to avoid using the in-built function (if this allows me to analyse all the points)? or (3) Start over in Matlab or a with programming language that allows me to analyse all the points and get all the data I need?
You can easily use the matlab built in function and it doesnt have the limitation like Excel and then import the results to excel
Yes, Excel FFT has the limit of data point 4096 and slow.
I programmed FFT using only Excel VBA code and there is no limit of the data point.
Below is the performance for the data point count.
There was a part where I could speed it up a bit, but I didn't b/c it makes the code less readable. However, even now, it may be the fastest FFT code in the Excel.
[data point] [FFT execution time]
4 kB 62ms
16 kB 235ms
64 kB 984ms
Computer Specification: 11th Gen Intel(R) Core(TM) i7-1165G7 # 2.80GHz
I implemented Cooley-Tukey algorithm, and use several techniques to speed-up the code running time in the Excel environment.
You can find the code and download the excel file in here. (https://infograph.tistory.com/351)
Otherwise you can review main logic as below:
'Module: fftProgram
'Author: HJ Park
'Date : 2019.5.18(v1.0), 2022.8.1(v2.0)
Option Explicit
Public Const myPI As Double = 3.14159265358979
Public Function Log2(X As Long) As Double
Log2 = Log(X) / Log(2)
End Function
Public Function Ceiling(ByVal X As Double, Optional ByVal Factor As Double = 1) As Double
' X is the value you want to round
' Factor is the multiple to which you want to round
Ceiling = (Int(X / Factor) - (X / Factor - Int(X / Factor) > 0)) * Factor
End Function
Public Function Floor(ByVal X As Double, Optional ByVal Factor As Double = 1) As Double
' X is the value you want to round
' Factor is the multiple to which you want to round
Floor = Int(X / Factor) * Factor
End Function
' return 0 if N is 2^n value,
' return (2^n - N) if N is not 2^n value. 2^n is Ceiling value.
' return -1, if error
Public Function IsPowerOfTwo(N As Long) As Long
If N = 0 Then GoTo EXIT_FUNCTION
Dim c As Long, F As Double
c = Ceiling(Log2(N)) 'Factor=0, therefore C is an integer number
F = Floor(Log2(N))
If c = F Then
IsPowerOfTwo = 0
Else
IsPowerOfTwo = (2 ^ c - N)
End If
Exit Function
EXIT_FUNCTION:
IsPowerOfTwo = -1
End Function
''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''
Function MakePowerOfTwoSize(ByRef r As Range, ByVal fillCount As Long) As Boolean
Dim arr() As Integer
On Error GoTo ERROR_HANDLE
'1)make a array with zero
ReDim arr(0 To fillCount - 1) As Integer
'2)set a range to be filled with zero
Dim fillRowStart As Long
Dim fillRange As Range
fillRowStart = r.Row + r.Rows.Count
Set fillRange = Range(Cells(fillRowStart, r.Column), Cells(fillRowStart + fillCount - 1, r.Column))
'3)fill as zero
fillRange = arr
'4)update range area to be extended
Set r = Union(r, fillRange)
MakePowerOfTwoSize = True
Exit Function
ERROR_HANDLE:
MakePowerOfTwoSize = False
End Function
' read the range and return it as complex value array
Function Range2Array(r As Range) As Complex()
Dim i As Long, size As Long
Dim arr() As Complex
size = r.Rows.Count
ReDim arr(0 To size - 1) As Complex
Dim re As Double, im As Double
On Error GoTo ERROR_HANDLE
For i = 1 To size
arr(i - 1) = String2Complex(r.Rows(i).Value)
Next i
Range2Array = arr
Exit Function
ERROR_HANDLE:
MsgBox "Error: " & i
End Function
Function ArrangedNum(num As Long, numOfBits As Integer) As Long
Dim arr() As Byte
Dim i As Integer, j As Integer
Dim k As Long
If (2 ^ numOfBits) <= num Then GoTo EXIT_FUNCTION
'1) Decimal number -> Reversed Binary array : (13,4) -> {1,1,0,1} -> {1,0,1,1}
ReDim arr(0 To numOfBits - 1) As Byte
For i = 0 To numOfBits - 1
j = (numOfBits - 1) - i
k = Int((num / (2 ^ j)))
arr(j) = (k And 1)
Next i
'2) Reversed Binary -> Decimal: {1,0,1,1} -> 1*2^3 + 0*2^2 + 1*2&1 + 1 = 11
Dim d As Long
For i = 0 To numOfBits - 1
d = d + (arr(i) * 2 ^ (numOfBits - 1 - i))
Next i
ArrangedNum = d
Exit Function
EXIT_FUNCTION:
ArrangedNum = 0
End Function
' rangeArr[1 to n, 1]
Function arrangeToFFTArray(arr() As Complex, size As Long, numOfBits As Integer) As Complex()
Dim i As Long, j As Long
Dim arrangedArr() As Complex
ReDim arrangedArr(0 To size - 1) As Complex
For i = 0 To size - 1
j = ArrangedNum(i, numOfBits) '{000,001,010, 011, 100, 101, 110, 111} -> {0, 4, 2, 6, 1, 5, 3, 7}
arrangedArr(j) = arr(i)
Next i
arrangeToFFTArray = arrangedArr
End Function
' calculate convolution ring W
' W[k] = cos(theta) - isin(theta)
' theta = (2pi*k/N)
Function CalculateW(cnt As Long, isInverse As Boolean) As Complex()
Dim arr() As Complex
Dim i As Long
Dim T As Double, theta As Double
Dim N As Long, N2 As Long
N = cnt
N2 = N / 2
ReDim arr(0 To N2 - 1) As Complex 'enough to calculate 0 to (N/2 -1)
T = 2 * myPI / CDbl(N)
If isInverse Then
For i = 0 To N2 - 1
theta = -(T * i)
arr(i) = Cplx(Cos(theta), -Sin(theta))
Next i
Else
For i = 0 To N2 - 1
theta = T * i
arr(i) = Cplx(Cos(theta), -Sin(theta))
Next i
End If
CalculateW = arr
End Function
' X({0,1}, [0,n-1]): 2d array. (0, n) <--> (1,n)
' src: src index of the array. 0 or 1
' tgt: tgt index of the array. 1 or 0
' s : starting index of the data in the array
' size: region size to be calculated
' kJump : k's jumping value
' W(0 ~ n-1) : Convolution ring
Sub RegionFFT(X() As Complex, src As Integer, tgt As Integer, _
s As Long, size As Long, kJump As Long, W() As Complex)
Dim i As Long, e As Long
Dim half As Long
Dim k As Long
Dim T As Complex
' Xm+1[i] = Xm[i] + Xm[i+half]W[k]
' Xm+1[i+half] = Xm[i] - Xm[i+half]W[k]
k = 0
e = s + (size / 2) - 1
half = size / 2
For i = s To e
T = CMult(X(src, i + half), W(k))
X(tgt, i) = CAdd(X(src, i), T)
X(tgt, i + half) = CSub(X(src, i), T)
k = k + kJump
Next i
End Sub
Sub WriteToTarget(tgtRange As Range, X() As Complex, tgtIdx As Integer, N As Long, roundDigit As Integer)
Dim i As Long
Dim arr() As Variant
ReDim arr(0 To N - 1) As Variant
For i = 0 To N - 1
If X(tgtIdx, i).im < 0 Then
arr(i) = Round(X(tgtIdx, i).re, roundDigit) & Round(X(tgtIdx, i).im, roundDigit) & "i"
Else
arr(i) = Round(X(tgtIdx, i).re, roundDigit) & "+" & Round(X(tgtIdx, i).im, roundDigit) & "i"
End If
Next i
tgtRange.Rows = Application.Transpose(arr)
End Sub
' xRange: input data
' tgtRange: output range
' isInverse: FFT or IFFT
Public Function FFT_Forward(xRange As Range, tgtRangeStart As Range, roundDigit As Integer, isInverse As Boolean) As Complex()
Dim i As Long, N As Long
Dim totalLoop As Integer, curLoop As Integer 'enough as Integer b/c it is used for loop varoable
Dim xArr() As Complex, xSortedArr() As Complex
Dim W() As Complex 'convolution ring
Dim X() As Complex 'output result
Dim errMsg As String
errMsg = "Uncatched error"
'1) check whether 2^r count data, if not pad to zero
Dim fillCount As Long
N = xRange.Rows.Count
fillCount = IsPowerOfTwo(N)
If fillCount = -1 Then
errMsg = "No input data. Choose input data"
GoTo ERROR_HANDLE
End If
If fillCount <> 0 Then
If MakePowerOfTwoSize(xRange, fillCount) = False Then 'xRange's size will be chnaged
errMsg = "Error while zero padding"
GoTo ERROR_HANDLE
End If
End If
'2) calculate loop count for FFT: 2->1 4->2 8->3 ...
N = xRange.Rows.Count 'xRange's size can be changed so read one more...
totalLoop = Log2(N)
'3) sort x for 2's FFT : convert to reversed binary and then convert to decimal
xArr = Range2Array(xRange) 'xArr[0,n-1]
xSortedArr = arrangeToFFTArray(xArr, N, totalLoop) 'xSortedArr[0,n-1]
'4) calculate W
W = CalculateW(N, isInverse)
'5) use 2-dimensional array to save memory space. X[0, ] <-> X[1, ]
ReDim X(0 To 1, 0 To N - 1) As Complex
For i = 0 To N - 1
X(0, i) = xSortedArr(i)
Next i
'6) Do 2's FFT with sorted x
Dim srcIdx As Integer, tgtIdx As Integer
Dim kJump As Long, regionSize As Long
tgtIdx = 0
For curLoop = 0 To totalLoop - 1
tgtIdx = (tgtIdx + 1) Mod 2
srcIdx = (tgtIdx + 1) Mod 2
regionSize = 2 ^ (curLoop + 1) ' if N=8: 2 -> 4 -> 8
kJump = 2 ^ (totalLoop - curLoop - 1) ' if N=8: 4 -> 2 -> 1
i = 0
Do While i < N
Call RegionFFT(X, srcIdx, tgtIdx, i, regionSize, kJump, W)
i = i + regionSize
Loop
Next curLoop
'7)return the value
Dim resultIdx As Integer
If (totalLoop Mod 2) = 0 Then resultIdx = 0 Else resultIdx = 1
Dim result() As Complex
ReDim result(0 To N - 1) As Complex
If isInverse = True Then
For i = 0 To N - 1
result(i) = CDivR(X(resultIdx, i), N)
Next i
Else
For i = 0 To N - 1
result(i) = X(resultIdx, i)
Next i
End If
FFT_Forward = result
Exit Function
ERROR_HANDLE:
Err.Raise Number:=vbObjectError, Description:=("FFT calculation error: " & errMsg)
End Function
Public Sub FFT(xRange As Range, tgtRangeStart As Range, roundDigit As Integer)
Dim X() As Complex
Dim tgtRange As Range
'1. calculate FFT_forward value
On Error GoTo ERROR_HANDLE
X = FFT_Forward(xRange, tgtRangeStart, roundDigit, False)
'2. write to the worksheet
Dim N As Long
N = UBound(X) - LBound(X) + 1
Dim i As Long
Dim arr() As Variant
ReDim arr(0 To N - 1) As Variant
For i = 0 To N - 1
If X(i).im < 0 Then
arr(i) = Round(X(i).re, roundDigit) & Round(X(i).im, roundDigit) & "i"
Else
arr(i) = Round(X(i).re, roundDigit) & "+" & Round(X(i).im, roundDigit) & "i"
End If
Next i
Set tgtRange = Range(Cells(tgtRangeStart.Row, tgtRangeStart.Column), Cells(tgtRangeStart.Row + N - 1, tgtRangeStart.Column))
tgtRange.Rows = Application.Transpose(arr)
Exit Sub
ERROR_HANDLE:
End Sub
Public Sub IFFT(xRange As Range, tgtRangeStart As Range, roundDigit As Integer)
Dim X() As Complex
Dim tgtRange As Range
'1. calculate FFT_forward value
On Error GoTo ERROR_HANDLE
X = FFT_Forward(xRange, tgtRangeStart, roundDigit, True)
'2.write to the worksheet
Dim N As Long
N = UBound(X) - LBound(X) + 1
Dim arr() As Variant
ReDim arr(0 To N - 1) As Variant
Dim i As Long
For i = 0 To N - 1
arr(i) = Round(X(i).re, roundDigit)
Next i
Set tgtRange = Range(Cells(tgtRangeStart.Row, tgtRangeStart.Column), Cells(tgtRangeStart.Row + N - 1, tgtRangeStart.Column))
tgtRange.Rows = Application.Transpose(arr)
Exit Sub
ERROR_HANDLE:
End Sub
Sub LoadFFTForm()
FFT_Form.Show
In alternative to the VBA solution from HeeJin, with LAMBDA functions in recent versions of Excel it is possible to implement the FFT as a pure formula (i.e. without VBA).
One such implementation is https://github.com/altomani/XL-FFT.
For power of two length it uses a recursive radix-2 Cooley-Tukey algorithm
and for other length a version of Bluestein's algorithm that reduces the calculation to a power of two case.

Retrieve data from Excel sheet for Artificial Neural Network training

I started to write code for a neural network.
The training data set is in an Excel sheet - two inputs and two outputs.
I am struggling to import the data into VBA so the network can be trained.
Code for the training part
Private Sub Train_Click()
alpha = 0.3
mu = 0.8
n = 4
m = 4
Dim I, J, K As Integer
Dim TrainError As Double
Dim TrainingData As String
NumCases = 123
For J = 0 To NumCases - 1
For I = 0 To m
X1(J, I) = Sheets("Sheet1").Cells(I, J).String
Next I
targval(J) = X1(J, n)
Next J
Call Init(n, m)
J = 0
Do Until J = 1000 And TrainError = 0
For I = 0 To NumCases - 1
For K = 0 To n - 1
InputNeuron(K) = X1(I, K)
Next
Call HiddenInput(n, m)
Call HiddenTransfer(m)
Call OutputInput(m)
Call OutputTransfer
Call UpdateOut(I, m)
Call UpdateHidden(n, m)
TrainError = TrainError + (targval(I) - oout) ^ 2
Next I
TrainError = Sqrt(TrainError / NumCases)
If TrainError < 0.01 Then
Exit Do
End If
J = J + 1
Loop
End Sub
If your problem is to import the data, I presume the issue is inside the first loop:
X1(J, I) = Sheets("Sheet1").Cells(I, J).String
If so, you could just try to use a method that reads your data given a Range. You declare an array to hold the input layer:
Public inputv() As Double '// the input layer data
and then populate it given the range of the data, lets say "C19:C27", with this method:
Private Sub loadInput(ByRef r As Range)
Dim s As Range
Set s = r.Resize(1, 1)
// this way you can even evaluate the number of trainning examples, m
m = r.Rows.Count
ReDim inputv(0 To m - 1, 0 To n - 1)
Dim i, j As Integer
For i = 0 To m - 1
For j = 0 To n - 1
inputv(i, j) = s(i + 1, j + 1).Value
Next j
Next i
End Sub

cubic roots using vba

I am lookin for a solution to find cubic roots in Excel. I found the below code at this website.
http://www.mrexcel.com/forum/excel-questions/88804-solving-equations-excel.html
unfortunately, it doesn't work for me - I get #VALUE! when I run it and since I am only learning VBA, I have not had luck debugging it.
Sub QUBIC(P As Double, Q As Double, R As Double, ROOT() As Double)
' Q U B I C - Solves a cubic equation of the form:
' y^3 + Py^2 + Qy + R = 0 for real roots.
' Inputs:
' P,Q,R Coefficients of polynomial.
' Outputs:
' ROOT 3-vector containing only real roots.
' NROOTS The number of roots found. The real roots
' found will be in the first elements of ROOT.
' Method: Closed form employing trigonometric and Cardan
' methods as appropriate.
' Note: To translate and equation of the form:
' O'y^3 + P'y^2 + Q'y + R' = 0 into the form above,
' simply divide thru by O', i.e. P = P'/O', Q = Q'/O',
' etc.
Dim Z(3) As Double
Dim p2 As Double
Dim RMS As Double
Dim A As Double
Dim B As Double
Dim nRoots As Integer
Dim DISCR As Double
Dim t1 As Double
Dim t2 As Double
Dim RATIO As Double
Dim SUM As Double
Dim DIF As Double
Dim AD3 As Double
Dim E0 As Double
Dim CPhi As Double
Dim PhiD3 As Double
Dim PD3 As Double
Const DEG120 = 2.09439510239319
Const Tolerance = 0.00001
Const Tol2 = 1E-20
' ... Translate equation into the form Z^3 + aZ + b = 0
p2 = P ^ 2
A = Q - p2 / 3
B = P * (2 * p2 - 9 * Q) / 27 + R
RMS = Sqr(A ^ 2 + B ^ 2)
If RMS < Tol2 Then
' ... Three equal roots
nRoots = 3
ReDim ROOT(0 To nRoots)
For i = 1 To 3
ROOT(i) = -P / 3
Next i
Exit Sub
End If
DISCR = (A / 3) ^ 3 + (B / 2) ^ 2
If DISCR > 0 Then
t1 = -B / 2
t2 = Sqr(DISCR)
If t1 = 0 Then
RATIO = 1
Else
RATIO = t2 / t1
End If
If Abs(RATIO) < Tolerance Then
' ... Three real roots, two (2 and 3) equal.
nRoots = 3
Z(1) = 2 * QBRT(t1)
Z(2) = QBRT(-t1)
Z(3) = Z(2)
Else
' ... One real root, two complex. Solve using Cardan formula.
nRoots = 1
SUM = t1 + t2
DIF = t1 - t2
Z(1) = QBRT(SUM) + QBRT(DIF)
End If
Else
' ... Three real unequal roots. Solve using trigonometric method.
nRoots = 3
AD3 = A / 3#
E0 = 2# * Sqr(-AD3)
CPhi = -B / (2# * Sqr(-AD3 ^ 3))
PhiD3 = Acos(CPhi) / 3#
Z(1) = E0 * Cos(PhiD3)
Z(2) = E0 * Cos(PhiD3 + DEG120)
Z(3) = E0 * Cos(PhiD3 - DEG120)
End If
' ... Now translate back to roots of original equation
PD3 = P / 3
ReDim ROOT(0 To nRoots)
For i = 1 To nRoots
ROOT(i) = Z(i) - PD3
Next i
End Sub
Function QBRT(X As Double) As Double
' Signed cube root function. Used by Qubic procedure.
QBRT = Abs(X) ^ (1 / 3) * Sgn(X)
End Function
Can anyone please guide me on how to fix it, so I can run it. Thanks.
EDIT: This is how I am running it in Excel (I changed Qubic to be a function instead of sub)
cells A1:A3 contain p,q, r respectively
cells B1:B3 contain Roots()
cells C1:C3 contain array for the output of Qubic
A1:1
A2:1
A3:1
B1:0.1
B2:0.1
B3:0.1
C1:
C2:
C3:
{=QUBIC(A1,A2,A3,B1:B3)}
ADD: now that it works with the fix from #assylias, I am trying the following from another sheet:
Function ParamAlpha(p,q,r) as Double
Dim p as Double
Dim q as Double
Dim r as Double
p=-5
q=-2
r=24
Dim Alpha as Double
Dim AlphaVector() as Double
AlphaVector=QubicFunction(p,q,r)
Alpha=FindMinPositiveValue(AlphaVector)
End Function
Function FindMinPositiveValue(AlphaVector) As Double
Dim N As Integer, i As Integer
N = AlphaVector.Cells.Count
Dim Alpha() As Double
ReDim Alpha(N) As Double
For i = 1 To N
If AlphaVector(i) > 0 Then
Alpha(i) = AlphaVector(i)
Else
Alpha(i) = 100000000000#
End If
Next i
FindMinPositiveValue = Application.Min(Alpha)
End Function
In Excel, I call =ParamAlpha(-5,-2,24) and it returns #VALUE!
If you add the following procedure, it will show the results in a message box. You can then modify it to do something else as you require:
Public Sub test()
Dim p As Double
Dim q As Double
Dim r As Double
Dim roots() As Double
p = 1
q = 1
r = 1
QUBIC p, q, r, roots
Dim i As Long
Dim result As String
result = "("
For i = LBound(roots, 1) To UBound(roots, 1)
result = result & roots(i) & ","
Next i
result = Left(result, Len(result) - 1) & ")"
MsgBox "Roots of y^3 + " & p & ".y^2 + " & r & ".y + " & r & " = 0 has the following roots: " & result
End Sub
Alternatively, if you want the result in the form of a fomula array directly in a spreadsheet, you can add the following function in the same module:
Public Function QubicFunction(p As Double, q As Double, r As Double) As Double()
Dim roots() As Double
QUBIC p, q, r, roots
QubicFunction = roots
End Function
You then call it from Excel by selecting a few cells (horizontally, for example A1:B1) and press CTRL+SHIFT+ENTER:
=QubicFunction(1, 1, 1)

Resources