I'm trying to implement a Fast Fourier Transform (Radix-2) in MS's Excel VBA. The code I'm using pulls data from a range in the worksheet, does the calculations, then dumps the results in the adjacent columns. What I'm having trouble with is 1) know what to do with the resulting X[k] arrays, and 2) matching these results with the results from Excel's built in FFT (they do not currently match). The code is shown below. Thanks in advance for your help.
Sub Enforce_DecimationInTime()
On Error GoTo ERROR_HANDLING
Dim SubName As String
SubName = "Enforce_DecimationInTime()"
Dim WS As Worksheet
Dim n As Long, v As Long, LR As Long, x As Long
Set WS = Worksheets("FFT")
LR = WS.Range("A" & Rows.Count).End(xlUp).Row
n = LR - 1
Do Until 2 ^ x <= n And 2 ^ (x + 1) > n 'locates largest power of 2 from size of input array
x = x + 1
Loop
n = n - (n - 2 ^ x) 'calculates n using the largest power of 2
If n + 1 <> WS.Range("A" & Rows.Count).End(xlUp).Row Then
WS.Range("A" & 2 ^ x + 2 & ":A" & LR).Delete xlUp 'deletes extra input data
End If
v = WorksheetFunction.Log(n, 2) 'calculates number of decimations necessary
Application.ScreenUpdating = False
For x = 1 To v
Call Called_Core.DecimationInTime(WS, n, 2 ^ x, x) 'calls decimation in time subroutine
Next x
Application.ScreenUpdating = True
Exit Sub
ERROR_HANDLING:
MsgBox "Error encountered in " & SubName & ": exiting subroutine." _
& vbNewLine _
& vbNewLine & "Error description: " & Err.Description _
& vbNewLine & "Error number: " & Err.Number, vbCritical, Title:="Error!"
End
End Sub
The above subroutine calls the below subroutine through a For/Next loop to the count of "v".
Sub DecimationInTime(WS As Worksheet, n As Long, Factor As Integer, x As Long)
On Error GoTo ERROR_HANDLING
Dim SubName As String
SubName = "DecimationInTime()"
Dim f_1() As Single, f_2() As Single
Dim i As Long, m As Long, k As Long
Dim TFactor_N1 As String, TFactor_N2 As String, X_k() As String
Dim G_1() As Variant, G_2() As Variant
ReDim f_1(0 To n / Factor - 1) As Single
ReDim f_2(0 To n / Factor - 1) As Single
ReDim G_1(0 To n / 1 - 1) As Variant
ReDim G_2(0 To n / 1 - 1) As Variant
ReDim X_k(0 To n - 1) As String
TFactor_N1 = WorksheetFunction.Complex(0, -2 * WorksheetFunction.Pi / (n / 1)) 'twiddle factor for N
TFactor_N2 = WorksheetFunction.Complex(0, -2 * WorksheetFunction.Pi / (n / 2)) 'twiddle factor for N/2
For i = 0 To n / Factor - 1
f_1(i) = WS.Range("A" & 2 * i + 2).Value 'assign input data
f_2(i) = WS.Range("A" & 2 * i + 3).Value 'assign input data
Next i
WS.Cells(1, 1 + x).Value = "X[" & x & "]" 'labels X[k] column with k number
For k = 0 To n / 2 - 1
For m = 0 To n / Factor - 1
G_1(m) = WorksheetFunction.ImProduct(WorksheetFunction.ImPower(TFactor_N2, k * m), WorksheetFunction.Complex(f_1(m), 0)) 'defines G_1[m]
G_2(m) = WorksheetFunction.ImProduct(WorksheetFunction.ImPower(TFactor_N2, k * m), WorksheetFunction.Complex(f_2(m), 0)) 'defines G_2[m]
Next m
X_k(k) = WorksheetFunction.ImSum(WorksheetFunction.ImSum(G_1), WorksheetFunction.ImProduct(WorksheetFunction.ImSum(G_2), WorksheetFunction.ImPower(TFactor_N1, k))) 'defines X[k] for k
If k <= n / 2 Then X_k(k + n / 2) = WorksheetFunction.ImSum(WorksheetFunction.ImSum(G_1), WorksheetFunction.ImProduct(WorksheetFunction.ImSum(G_2), WorksheetFunction.ImPower(TFactor_N1, k), WorksheetFunction.Complex(-1, 0))) 'defines X[k] for k + n/2
WS.Cells(k + 2, 1 + x).Value = X_k(k)
WS.Cells(k + 2 + n / 2, 1 + x).Value = X_k(k + n / 2)
Next k
Exit Sub
ERROR_HANDLING:
MsgBox "Error encountered in " & SubName & ": exiting subroutine." _
& vbNewLine _
& vbNewLine & "Error description: " & Err.Description _
& vbNewLine & "Error number: " & Err.Number, vbCritical, Title:="Error!"
End
End Sub
I went back through the process and determined my problem was that I had assigned the wrong values to the twiddle factors, TFactor_N1 and TFactor_N2. After fixing this problem and adjusting which values are displayed, I was able to get the same results as Excel's built in FFT. The fixed code is show below.
Sub Enforce_DecimationInTime()
On Error GoTo ERROR_HANDLING
Dim SubName As String
SubName = "Enforce_DecimationInTime()"
Dim WS As Worksheet
Dim n As Long, v As Long, LR As Long, x As Long
Dim TFactor_N1 As String, TFactor_N2 As String
Set WS = Worksheets("FFT")
LR = WS.Range("A" & Rows.Count).End(xlUp).Row
n = LR - 1
Do Until 2 ^ x <= n And 2 ^ (x + 1) > n 'locates largest power of 2 from size of input array
x = x + 1
Loop
n = n - (n - 2 ^ x) 'calculates n using the largest power of 2
If n + 1 <> WS.Range("A" & Rows.Count).End(xlUp).Row Then
WS.Range("A" & 2 ^ x + 2 & ":A" & LR).Delete xlUp 'deletes extra input data
End If
v = WorksheetFunction.Log(n, 2) 'calculates number of decimations necessary
TFactor_N1 = WorksheetFunction.ImExp(WorksheetFunction.Complex(0, -2 * WorksheetFunction.Pi / (n / 1))) 'twiddle factor for N
TFactor_N2 = WorksheetFunction.ImExp(WorksheetFunction.Complex(0, -2 * WorksheetFunction.Pi / (n / 2))) 'twiddle factor for N/2
Application.ScreenUpdating = False
For x = 1 To v
Call Called_Core.DecimationInTime(WS, n, 2 ^ x, x, TFactor_N1, TFactor_N2) 'calls decimation in time subroutine
Next x
Application.ScreenUpdating = True
Exit Sub
ERROR_HANDLING:
MsgBox "Error encountered in " & SubName & ": exiting subroutine." _
& vbNewLine _
& vbNewLine & "Error description: " & Err.Description _
& vbNewLine & "Error number: " & Err.Number, vbCritical, Title:="Error!"
End
End Sub
Sub DecimationInTime(WS As Worksheet, n As Long, Factor As Integer, x As Long, TFactor_N1 As String, TFactor_N2 As String)
On Error GoTo ERROR_HANDLING
Dim SubName As String
SubName = "DecimationInTime()"
Dim f_1() As String, f_2() As String
Dim i As Long, m As Long, k As Long
Dim X_k() As String
Dim G_1() As Variant, G_2() As Variant
ReDim f_1(0 To n / Factor - 1) As String
ReDim f_2(0 To n / Factor - 1) As String
ReDim G_1(0 To n / 1 - 1) As Variant
ReDim G_2(0 To n / 1 - 1) As Variant
ReDim X_k(0 To n - 1) As String
For i = 0 To n / Factor - 1
f_1(i) = WS.Cells(2 * i + 2, 1).Value 'assign input data
f_2(i) = WS.Cells(2 * i + 3, 1).Value 'assign input data
Next i
For k = 0 To n / 2 - 1
For m = 0 To n / Factor - 1 'defines G_1[m] and G_2[m]
G_1(m) = WorksheetFunction.ImProduct(WorksheetFunction.ImPower(TFactor_N2, k * m), f_1(m))
G_2(m) = WorksheetFunction.ImProduct(WorksheetFunction.ImPower(TFactor_N2, k * m), f_2(m))
Next m 'defines X[k] for k and k + n/2
X_k(k) = WorksheetFunction.ImSum(WorksheetFunction.ImSum(G_1), WorksheetFunction.ImProduct(WorksheetFunction.ImSum(G_2), WorksheetFunction.ImPower(TFactor_N1, k)))
If k <= n / 2 Then X_k(k + n / 2) = WorksheetFunction.ImSub(WorksheetFunction.ImSum(G_1), WorksheetFunction.ImProduct(WorksheetFunction.ImSum(G_2), WorksheetFunction.ImPower(TFactor_N1, k)))
If x = 1 Then
WS.Cells(k + 2, 1 + x).Value = X_k(k)
WS.Cells(k + 2 + n / 2, 1 + x).Value = X_k(k + n / 2)
End If
Next k
Exit Sub
ERROR_HANDLING:
MsgBox "Error encountered in " & SubName & ": exiting subroutine." _
& vbNewLine _
& vbNewLine & "Error description: " & Err.Description _
& vbNewLine & "Error number: " & Err.Number, vbCritical, Title:="Error!"
End
End Sub
The function call is not good
Call Called_Core.DecimationInTime(WS, n, 2 ^ x, x, TFactor_N1, TFactor_N2)
It should be:
Call DecimationInTime(WS, n, 2 ^ x, x, TFactor_N1, TFactor_N2)
Implementing FFT in ExcelVBA is kind of involved, but not too bad. For typical applications, the input signal is usually real-valued, not coplex-valued. This would be the case if you were measuring a dynamic signal from a velocity or acceleration transducer, or microphone.
Shown here is a DFT that will convert any number of input pairs, (eg. time and velocity). They do not have to be 2^N number of data (required for FFT). Usually the time is evenly divided so that all you need is DeltaTime (the time interval between your data). Let me drop in the code here:
Sub dft()
Dim ytime(0 To 18000) As Double 'Time history values such as velocity or acceleration
Dim omega(0 To 8096) As Double 'Discreet frequency values used in transform
Dim yfreqr(0 To 8096) As Double 'Real valued component of transform
Dim yfreqi(0 To 8096) As Double 'Imaginary component of transform
Dim t As Double, sumr As Double, sumi As Double, sum As Double 'Cumulative sums
Dim omegadt As Double, omegat As Double, deltime As Double 'More constants self explanitory
Dim wksInData As Worksheet 'This is the Excel worksheet where the data is read from and written to
Dim s As Integer, i As Integer 'Counters for the transform loops
Dim transdim As Integer 'Dimension of the transform
'Read number of values to read, delta time
'Read in dimension of transform
Set wksInData = Worksheets("DFT Input") 'This is what I named the worksheet
numval = wksInData.Cells(5, 2)
deltime = wksInData.Cells(6, 2)
transdim = wksInData.Cells(5, 4)
For i = 0 To numval - 1 'Read in all the input data, its just a long column
ytime(i) = wksInData.Cells(i + 8, 2) 'So the input starts on row 8 column 2 (time values on column 1 for plotting)
Next i 'Loop until you have all the numbers you need
'Start the transform outer loop...for each discreet frequency
'Value s is the counter from 0 to 1/2 transform dimension
'So if you have 2000 numbers to convert, transdim is 2000
For s = 0 To transdim / 2 'Since transform is complex valued, use only 1/2 the number of transdim
sumr = 0# 'Set the sum of real values to zero
sumi = 0# 'Set the sum of imaginary values to zero
omega(s) = 2# * 3.14159265 * s / (transdim * deltime) 'These are the discreet frequencies
omegadt = omega(s) * deltime 'Just a number used in computations
' Start the inner loop for DFT
For i = 0 To numval - 1
sumr = sumr + ytime(i) * Cos(omegadt * i) 'This is the real valued sum
sumi = sumi + ytime(i) * Sin(omegadt * i) 'This is the complex valued sum
Next i ' and back for more
yfreqr(s) = sumr * 2# / transdim 'This is what is called the twiddle factor, just a constant
yfreqi(s) = -sumi * 2# / transdim 'Imaginary component is negative
Next s
'One last adjustment for the first and last transform values
'They are only 1/2 of the rest, but it is easiest to do this now after the inner loop is done
yfreqr(0) = yfreqr(0) / 2# 'Beginning factor
yfreqi(0) = yfreqi(0) / 2#
yfreqr(transdim / 2) = yfreqr(transdim / 2) / 2# 'End factor
yfreqi(transdim / 2) = yfreqi(transdim / 2) / 2#
wksInData.Cells(2, 8) = "Output" 'Just a column text header
For s = 0 To transdim / 2 'And write the output to columns 3, 4, 5 to the worksheet
wksInData.Cells(s + 8, 3) = omega(s) 'remember that magnitude is sqrt(real ^2 + imaginary ^2 )
wksInData.Cells(s + 8, 4) = yfreqr(s) 'but you can do this with an Excel formula on the worksheet
wksInData.Cells(s + 8, 5) = yfreqi(s) 'same with phase angle = arctan(Imaginary/Real)
Next s 'End of writeout loop.
'This is the inverse DFT
'I like to check my calculation,
'Should get the original time series back
For i = 0 To numval - 1
sum = 0
t = deltime * i
For s = 0 To transdim / 2
omegat = omega(s) * t
sum = sum + yfreqr(s) * Cos(omegat) - yfreqi(s) * Sin(omegat)
Next s
ytime(i) = sum
Next i
In alternative to the VBA solutions already posted, recent versions of Excel allow to implement the FFT as a pure formula with LAMBDA functions (i.e. without any VBA code).
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.
Related
In VB6, I am trying to convert a number to binary but when the number has 10 digits i am always getting an Overflow error.
What is the data type where i can store a trillion number?
This is the code which is working when the number has less that 10 digits.
Public Function DecimalToBinary(DecimalNum As Double) As _
String
Dim tmp As String
Dim n As Double
n = DecimalNum
tmp = Trim(Str(n Mod 2))
n = n \ 2
Do While n <> 0
tmp = Trim(Str(n Mod 2)) & tmp
n = n \ 2
Loop
DecimalToBinary = tmp
End Function
One of the problems you will encounter is that the Mod operator will not work with values larger than a Long (2,147,483,647). You can rewrite a Mod function as described in this answer: VBA equivalent to Excel's mod function:
' Divide the number by 2.
' Get the integer quotient for the next iteration.
' Get the remainder for the binary digit.
' Repeat the steps until the quotient is equal to 0.
Public Function DecimalToBinary(DecimalNum As Double) As String
Dim tmp As String
Dim n As Double
n = DecimalNum
Do While n <> 0
tmp = Remainder(n, 2) & tmp
n = Int(n / 2)
Loop
DecimalToBinary = tmp
End Function
Function Remainder(Dividend As Variant, Divisor As Variant) As Variant
Remainder = Dividend - Divisor * Int(Dividend / Divisor)
End Function
You can also rewrite your function to avoid Mod altogether:
Public Function DecimalToBinary2(DecimalNum As Double) As String
Dim tmp As String
Dim n As Double
Dim iCounter As Integer
Dim iBits As Integer
Dim dblMaxSize As Double
n = DecimalNum
iBits = 1
dblMaxSize = 1
' Get number of bits
Do While dblMaxSize <= n
dblMaxSize = dblMaxSize * 2
iBits = iBits + 1
Loop
' Move back down one bit
dblMaxSize = dblMaxSize / 2
iBits = iBits - 1
' Work back down bit by bit
For iCounter = iBits To 1 Step -1
If n - dblMaxSize >= 0 Then
tmp = tmp & "1"
n = n - dblMaxSize
Else
' This bit is too large
tmp = tmp & "0"
End If
dblMaxSize = dblMaxSize / 2
Next
DecimalToBinary2 = tmp
End Function
This function finds the bit that is larger than your number and works back down, bit by bit, figuring out if the value for each bit can be subtracted from your number. It's a pretty basic approach but it does the job.
For both functions, if you want to have your binary string in groups of 8 bits, you can use a function like this to pad your string:
Public Function ConvertToBytes(p_sBits As String)
Dim iLength As Integer
Dim iBytes As Integer
iLength = Len(p_sBits)
If iLength Mod 8 > 0 Then
iBytes = Int(iLength / 8) + 1
Else
iBytes = Int(iLength / 8)
End If
ConvertToBytes = Right("00000000" & p_sBits, iBytes * 8)
End Function
I am trying to simulate the I/O of this website page
My Input sheet looks like this:
Now after taking the values from input sheet and arranging them in ascending order I got this in a temp worksheet :
This is what my results sheet looks like:
Now I have tried this after sorting process(didn't add code for sorting since it's not the problem):
Set rng = Union(wTime.Range("D6:D25"), wTime.Range("F6:F25"), wTime.Range("H6:H25"), wTime.Range("J6:J25"))
cnt1 = 1: cnt2 = 1: cnt3 = 1: cnt4 = 1
wTime.Range("A6:A25") = Empty 'Ticker
For i = 1 To 20
bckStroke(i) = wTemp.Range("A" & i + 1).Value
brstStroke(i) = wTemp.Range("C" & i + 1).Value
btrFly(i) = wTemp.Range("E" & i + 1).Value
frStyle(i) = wTemp.Range("G" & i + 1).Value
wTime.Range("A6:A25") = Empty
For Each cel In rng
If cel.Column = 4 And cel.Value = bckStroke(i) And cel.Value <> 0 And Trim(wTime.Cells(cel.Row, 1)) <> "Y" And cnt1 < 6 Then
wRes.Cells((cnt1 + 5 + (cnt1 - 1) * 2) - 1, 4) = wTime.Cells(cel.Row, 2) 'Athlete Name
wRes.Cells(cnt1 + 5 + (cnt1 - 1) * 2, 4) = bckStroke(i) 'Time
cnt1 = cnt1 + 1
wTime.Cells(cel.Row, 1) = "Y"
End If
If cel.Column = 6 And cel.Value = brstStroke(i) And cel.Value <> 0 And Trim(wTime.Cells(cel.Row, 1)) <> "Y" And cnt2 < 6 Then
wRes.Cells((cnt2 + 5 + (cnt2 - 1) * 2) - 1, 6) = wTime.Cells(cel.Row, 2) 'Athlete Name
wRes.Cells(cnt2 + 5 + (cnt2 - 1) * 2, 6) = brstStroke(i) 'Time
cnt2 = cnt2 + 1
wTime.Cells(cel.Row, 1) = "Y"
End If
If cel.Column = 8 And cel.Value = btrFly(i) And cel.Value <> 0 And Trim(wTime.Cells(cel.Row, 1)) <> "Y" And cnt3 < 6 Then
wRes.Cells((cnt3 + 5 + (cnt3 - 1) * 2) - 1, 8) = wTime.Cells(cel.Row, 2) 'Athlete Name
wRes.Cells(cnt3 + 5 + (cnt3 - 1) * 2, 8) = btrFly(i) 'Time
cnt3 = cnt3 + 1
wTime.Cells(cel.Row, 1) = "Y"
End If
If cel.Column = 10 And cel.Value = frStyle(i) And cel.Value <> 0 And Trim(wTime.Cells(cel.Row, 1)) <> "Y" And cnt4 < 6 Then
wRes.Cells((cnt4 + 5 + (cnt4 - 1) * 2) - 1, 10) = wTime.Cells(cel.Row, 2) 'Athlete Name
wRes.Cells(cnt4 + 5 + (cnt4 - 1) * 2, 10) = frStyle(i) 'Time
cnt4 = cnt4 + 1
wTime.Cells(cel.Row, 1) = "Y"
End If
Next cel
Next i
I just want to know the simplest logic to get the desired result after arranging them in ascending order (refer temp sheet) it should be easy but I can't seem to understand it.
Conditions that I know of for now:
Each team should have unique swimmers (i.e 4 Unique names in each team)
A swimmer can appear in other team as well if he has best time in other category as well. (E.g. Marcelo will appear in top 4 team since he has the best time in all 4 categories)
Teams with shortest time should be placed 1st in the list on result sheet. I think sorting in ascending order takes care of this it's matter of selecting right swimmer from the temp sheet list.
EDIT:
4. Relay Logic premise: Get all the combinations possible without 2 identical strings. And then sort them lowest to largest. I'd do the following: Get all the possible combinations and their sum with the following: *Combinations may still be buggy, since it may be variable to how many numbers you may have. This is just a guide to describe the process
Sub Combinations()
Dim i As Long, j As Long, k As Long, l As Long, m As Long, n As Long, o As Long, p As Long, q As Long
Dim CountComb As Long, lastrow As Long
Range("K2").Value = Now - 5
Application.ScreenUpdating = False
CountComb = 0: lastrow = 6
For i = 1 To 6: For j = 1 To 5
For k = 1 To 6: For l = 1 To 6
If Not (i = j Or i = k Or i = l Or j = k Or j = l Or k = l) Then
Range("K" & lastrow).Value = Range("A" & i).Value & "/" & _
Range("B" & j).Value & "/" & _
Range("C" & k).Value & "/" & _
Range("D" & l).Value
lastrow = lastrow + 1
CountComb = CountComb + 1
End If
Next: Next
Next: Next
Range("K1").Value = CountComb
Range("K3").Value = Now + 21
Application.ScreenUpdating = True
End Sub
Function TimeSum(Persons As String, Chr As String) As Double
Dim ArrayPersons() As String: ArrayPersons = Split(Persons, Chr)
Dim SumOfTime As Double
Dim ItemPerson As Variant
Dim NumberRoutines As Long: NumberRoutines = 2
Const SheetData = "Sheet1"
For Each ItemPerson In ArrayPersons
SumOfTime = Sheets(SheetData).Columns(NumberRoutines).Find(ItemPerson).Offset(0, -1).Value + SumOfTime
NumberRoutines = NumberRoutines + 2
Next ItemPerson
TimeSum = SumOfTime
End Function
Maybe you could define better the sub to do what you desire for, but, the last coding could guide you in the right path. In a second thought, you could get combinations in a dictionary instead.
[
[
This question has been asked before, but I can't find an answer that is easily applicable to Excel VBA.
Basically I want to do exactly what this poster has asked, but in VBA. I want to create an array, n x 2^n, where each line represents a different permutation of n variables which can be either 0 or 1.
I've played around with this for ages, and it's easy enough to do for a set n with loads of loops, but for a variable n I can't find anything that works.
Any code or just suggestions of ways of going about this would be much appreciated!
This will list the value in column A
Sub EasyAsCounting()
Dim N As Long, M As Long, K As Long
N = Application.InputBox(Prompt:="Enter N", Type:=1)
M = 2 ^ N - 1
For K = 0 To M
Cells(K + 1, 1) = "'" & Application.WorksheetFunction.Dec2Bin(K, N)
Next K
End Sub
EDIT#1
This stores the array in VBA only:
Sub EasyAsCounting()
Dim N As Long, M As Long, K As Long, ary, s As String
Dim J As Long
N = Application.InputBox(Prompt:="Enter N", Type:=1)
M = 2 ^ N - 1
ReDim ary(1 To M + 1, 1 To N)
For K = 0 To M
s = Application.WorksheetFunction.Dec2Bin(K, N)
For J = 1 To N
ary(K + 1, J) = Mid(s, J, 1)
Next J
Next K
'
'display the array
'
msg = ""
For K = 1 To M + 1
For J = 1 To N
msg = msg & " " & ary(K, J)
Next J
msg = msg & vbCrLf
Next K
MsgBox msg
End Sub
Here's one if you're not in Excel and don't have access to the functions. Or if you have a number greater than 511.
Sub MakePerms()
Dim i As Long, j As Long
Dim n As Long
Dim aPerms() As Byte
Dim lCnt As Long
Dim sOutput As String
Const lVar As Long = 4
ReDim aPerms(1 To 2 ^ lVar, 1 To lVar)
For i = 0 To UBound(aPerms, 1) - 1
n = i
lCnt = lVar
aPerms(i + 1, lCnt) = CByte(n Mod 2)
n = n \ 2
Do While n > 0
lCnt = lCnt - 1
aPerms(i + 1, lCnt) = CByte(n Mod 2)
n = n \ 2
Loop
Next i
For i = LBound(aPerms, 1) To UBound(aPerms, 1)
sOutput = vbNullString
For j = LBound(aPerms, 2) To UBound(aPerms, 2)
sOutput = sOutput & Space(1) & aPerms(i, j)
Next j
Debug.Print sOutput
Next i
End Sub
I'm converting my MATLAB code into an excel document but are having difficulty transferring the following formula across.
x=(b/N)*(-floor(N/2):floor(N/2))
Which if for example b =2 and N = 5
the results will be :
x = -0.8000 -0.4000 0 0.4000 0.8000
and if b = 2 and N =6 the results will be:
x = -1.0000 -0.6667 -0.3333 0 0.3333 0.6667 1.0000
Note: If N is odd there are N elements in x, if N is even there are N+1 elements in x.
Any ideas for how to write it within Excel?
This answer is follows from comments to my another answer.
It's a really big array formula. Select F3:F19 , enter formula in the formula bar and press CTRL+SHIFT+ENTER to evaluate it.
(suppose your b in A1 cell, your N in C4 cell.
=IFERROR(INDEX(($A$1/$C$4)*INT(($C$4-(ROW(INDIRECT($C$4 & ":" & 3* $C$4-1))-$C$4))/2),SMALL(IF(MATCH(($A$1/$C$4)*INT(($C$4-(ROW(INDIRECT($C$4 & ":" & 3* $C$4-1))-$C$4))/2),($A$1/$C$4)*INT(($C$4-(ROW(INDIRECT($C$4 & ":" & 3* $C$4-1))-$C$4))/2),0)=ROW(INDIRECT("1:" & ROWS(($A$1/$C$4)*INT(($C$4-(ROW(INDIRECT($C$4 & ":" & 3* $C$4-1))-$C$4))/2)))),MATCH(($A$1/$C$4)*INT(($C$4-(ROW(INDIRECT($C$4 & ":" & 3* $C$4-1))-$C$4))/2),($A$1/$C$4)*INT(($C$4-(ROW(INDIRECT($C$4 & ":" & 3* $C$4-1))-$C$4))/2),0),""),ROW(IDIRECT("1:" & ROWS(($A$1/$C$4)*INT(($C$4-(ROW(INDIRECT($C$4 & ":" & 3* $C$4-1))-$C$4))/2)))))),"")
here is my test workbook
In Excel VBA:
Dim j As Integer = 0
Dim b As Double, N As Double, M As Double, k As Double
b = Cells(3, 3)
N = Cells(3, 4)
If Int(N/2) = N/2 Then
M = N + 1
Else
M = N
End If
For k = -(b/N)*(floor(N/2) To (b/N)*(floor(N/2) Step 2*(b/N)*(floor(N/2)/M
j = j + 1
x(j)=k
Next k
I have been asked to ask this question again and in a little different context. This is the previous post:
Filtering in VBA after finding combinations
I would like to make this code possible with 100 different variables without having excel run out of memory and reducing the execution time significantly.
The problem with the code below is that if I have 100 boxes, excel will run out of memory in the line "Result(0 To 2 ^ NumFields - 2)" ( The code works for < 10 boxes)
This is my input:
3 A B C D E ...
7.7 3 1 1 1 2 ...
5.5 2 1 2 3 3 ...
This is the code:
Function stackBox()
Dim ws As Worksheet
Dim width As Long
Dim height As Long
Dim numOfBox As Long
Dim optionsA() As Variant
Dim results() As Variant
Dim str As String
Dim outputArray As Variant
Dim i As Long, j As Long
Dim currentSymbol As String
'------------------------------------new part----------------------------------------------
Dim maxHeight As Double
Dim maxWeight As Double
Dim heightarray As Variant
Dim weightarray As Variant
Dim totalHeight As Double
Dim totalWeight As Double
'------------------------------------new part----------------------------------------------
Set ws = Worksheets("Sheet1")
With ws
'clear last time's output
height = .Cells(.Rows.Count, 1).End(xlUp).row
If height > 3 Then
.Range(.Cells(4, 1), .Cells(height, 1)).ClearContents
End If
numOfBox = .Cells(1, 1).Value
width = .Cells(1, .Columns.Count).End(xlToLeft).Column
If width < 2 Then
MsgBox "Error: There's no item, please fill your item in Cell B1,C1,..."
Exit Function
End If
'------------------------------------new part----------------------------------------------
maxHeight = .Cells(2, 1).Value
maxWeight = .Cells(3, 1).Value
ReDim heightarray(1 To 1, 1 To width - 1)
ReDim weightarray(1 To 1, 1 To width - 1)
heightarray = .Range(.Cells(2, 2), .Cells(2, width)).Value
weightarray = .Range(.Cells(3, 2), .Cells(3, width)).Value
'------------------------------------new part----------------------------------------------
ReDim optionsA(0 To width - 2)
For i = 0 To width - 2
optionsA(i) = .Cells(1, i + 2).Value
Next i
GenerateCombinations optionsA, results, numOfBox
' copy the result to sheet only once
ReDim outputArray(1 To UBound(results, 1) - LBound(results, 1) + 1, 1 To 1)
Count = 0
For i = LBound(results, 1) To UBound(results, 1)
If Not IsEmpty(results(i)) Then
'rowNum = rowNum + 1
str = ""
totalHeight = 0#
totalWeight = 0#
For j = LBound(results(i), 1) To UBound(results(i), 1)
currentSymbol = results(i)(j)
str = str & currentSymbol 'results(i)(j) is the SYMBOL e.g. A, B, C
'look up box's height and weight , increment the totalHeight/totalWeight
updateParam currentSymbol, optionsA, heightarray, weightarray, totalHeight, totalWeight
Next j
If totalHeight < maxHeight And totalWeight < maxWeight Then
Count = Count + 1
outputArray(Count, 1) = str
End If
'.Cells(rowNum, 1).Value = str
End If
Next i
.Range(.Cells(4, 1), .Cells(UBound(outputArray, 1) + 3, 1)).Value = outputArray
End With
End Function
Sub updateParam(ByRef targetSymbol As String, ByRef symbolArray As Variant, ByRef heightarray As Variant, ByRef weightarray As Variant, ByRef totalHeight As Double, ByRef totalWeight As Double)
Dim i As Long
Dim index As Long
index = -1
For i = LBound(symbolArray, 1) To UBound(symbolArray, 1)
If targetSymbol = symbolArray(i) Then
index = i
Exit For
End If
Next i
If index <> -1 Then
totalHeight = totalHeight + heightarray(1, index + 1)
totalWeight = totalWeight + weightarray(1, index + 1)
End If
End Sub
Sub GenerateCombinations(ByRef AllFields() As Variant, _
ByRef Result() As Variant, ByVal numOfBox As Long)
Dim InxResultCrnt As Integer
Dim InxField As Integer
Dim InxResult As Integer
Dim i As Integer
Dim NumFields As Integer
Dim Powers() As Integer
Dim ResultCrnt() As String
NumFields = UBound(AllFields) - LBound(AllFields) + 1
ReDim Result(0 To 2 ^ NumFields - 2) ' one entry per combination
ReDim Powers(0 To NumFields - 1) ' one entry per field name
' Generate powers used for extracting bits from InxResult
For InxField = 0 To NumFields - 1
Powers(InxField) = 2 ^ InxField
Next
For InxResult = 0 To 2 ^ NumFields - 2
' Size ResultCrnt to the max number of fields per combination
' Build this loop's combination in ResultCrnt
ReDim ResultCrnt(0 To NumFields - 1)
InxResultCrnt = -1
For InxField = 0 To NumFields - 1
If ((InxResult + 1) And Powers(InxField)) <> 0 Then
' This field required in this combination
InxResultCrnt = InxResultCrnt + 1
ResultCrnt(InxResultCrnt) = AllFields(InxField)
End If
Next
If InxResultCrnt = 0 Then
Debug.Print "testing"
End If
'additional logic here
If InxResultCrnt >= numOfBox Then
Result(InxResult) = Empty
Else
' Discard unused trailing entries
ReDim Preserve ResultCrnt(0 To InxResultCrnt)
' Store this loop's combination in return array
Result(InxResult) = ResultCrnt
End If
Next
End Sub
Here's a version that does all the heavy lifting in variant arrays
(Combinations logic based on this answer for This Answer by Joubarc)
This runs on a sample dataset of 100 boxes with > 40,000 returned, and in < 1 second
Notes:
Execution time rises quickly if the Max number of boxes increases (eg 4 from 100: approx 13s)
If the number of returned results exceeds 65535, the code to tranpose the array into the sheet fails (last line of the sub) If you need to handle this may results, you will need to change the way results are returned to the sheet
Sub Demo()
Dim rNames As Range
Dim rHeights As Range
Dim rWeights As Range
Dim aNames As Variant
Dim aHeights As Variant
Dim aWeights As Variant
Dim MaxNum As Long
Dim MaxHeight As Double
Dim MaxWeight As Double
' *** replace these six line with your data ranges
Set rNames = Range([F5], [F5].End(xlToRight))
Set rHeights = rNames.Offset(1, 0)
Set rWeights = rNames.Offset(2, 0)
MaxNum = [C5]
MaxHeight = [C6]
MaxWeight = [C7]
aNames = rNames
aHeights = rHeights
aWeights = rWeights
Dim Result() As Variant
Dim n As Long, m As Long
Dim i As Long, j As Long
Dim iRes As Long
Dim res As String
Dim TestCombin() As Long
Dim TestWeight As Double
Dim TestHeight As Double
Dim idx() As Long
' Number of boxes
ReDim TestCombin(0 To MaxNum - 1)
n = UBound(aNames, 2) - LBound(aNames, 2) + 1
' estimate size of result array = number of possible combinations
For m = 1 To MaxNum
i = i + Application.WorksheetFunction.Combin(n, m)
Next
ReDim Result(1 To 3, 1 To i)
' allow for from 1 to MaxNum of boxes
iRes = 1
For m = 1 To MaxNum
ReDim idx(0 To m - 1)
For i = 0 To m - 1
idx(i) = i
Next i
Do
'Test current combination
res = ""
TestWeight = 0#
TestHeight = 0#
For j = 0 To m - 1
'Debug.Print aNames(1, idx(j) + 1);
res = res & aNames(1, idx(j) + 1)
TestWeight = TestWeight + aWeights(1, idx(j) + 1)
TestHeight = TestHeight + aHeights(1, idx(j) + 1)
Next j
'Debug.Print
If TestWeight <= MaxWeight And TestHeight <= MaxHeight Then
Result(1, iRes) = res
' optional, include actual Height and Weight in result
Result(2, iRes) = TestHeight
Result(3, iRes) = TestWeight
iRes = iRes + 1
End If
' Locate last non-max index
i = m - 1
While (idx(i) = n - m + i)
i = i - 1
If i < 0 Then
'All indexes have reached their max, so we're done
Exit Do
End If
Wend
'Increase it and populate the following indexes accordingly
idx(i) = idx(i) + 1
For j = i To m - 1
idx(j) = idx(i) + j - i
Next j
Loop
Next
' Return Result to sheet
Dim rng As Range
ReDim Preserve Result(1 To 3, 1 To iRes)
' *** Adjust returnm range to suit
Set rng = [E10].Resize(UBound(Result, 2), UBound(Result, 1))
rng = Application.Transpose(Result)
End Sub