Not sure if this is possible:
myString = 313233
counter = Len(myString)
Do while counter > 0
position = 1
take = 2
response.write (" counter:" & counter)
first_two = Mid(myString, position, take)
response.write (" Each loop:" & first_two)
position = position + 2
counter = counter - 2
Loop
Can someone tell me where I'm going wrong please? or is this possible via different method?
The code above is running once and returning: 31 not 31 32 33
Thanks.
UPDATE: Realized my error shortly after but now position won't increment to give to move up the variable
You set the position variable to 1 at the start of the Do loop. As it stands whenever Mid() is called it is passed position = 1 which will return 31.
Fix this by moving it outside the loop so position can increment.
myString = 313233
counter = Len(myString)
'Set before start of loop
position = 1
take = 2
Do while counter > 0
response.write (" counter:" & counter)
first_two = Mid(myString, position, take)
response.write (" Each loop:" & first_two)
'Use take variable so increment is always the same.
position = position + take
counter = counter - take
Loop
Code untested
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.
In my program I would like to sort players based on two values (score and previous rank) I have manage to sort based on just there score..
I would like to reorder if one or more player have the same score but the player with the lowest previous rank should display first.
dim mPlayer(30)
Class Player
dim score
dim name
dim lowestRank
End Class
dim sorted, i
dim tempPlayer
Set tempPlayer = New Player
sorted = False
Do Until sorted
sorted = True
For i = 0 To mNumPlayers - 2
If (mPlayer(i + 1).score > mPlayer(i).score) Then
' swap
sorted = False
Call CopytempPlayerData(tempPlayer, mPlayer(i))
Call CopytempPlayerData(mPlayer(i), mPlayer(i + 1))
Call CopytempPlayerData(mPlayer(i + 1), tempPlayer)
End If
Next
Loop
Set temptempPlayer = Nothing
lstPlayers.Clear()
For i = 0 To mPlayer - 1
lstPlayers.Items.add(mPlayer(i).name)
Next
Read If...Then...Else Statement documentation. Syntax:
' Block syntax:
If condition Then
[statements]
[ElseIf condition-n Then
[elseifstatements]] . . .
[Else
[elsestatements]]
End If
Single-Line syntax:
If condition Then statements [Else elsestatements ]
Apply to your circumstances as follows:
If (mPlayer(i + 1).score > mPlayer(i).score) Then
' swap
sorted = False
Call CopytempPlayerData(tempPlayer, mPlayer(i))
Call CopytempPlayerData(mPlayer(i), mPlayer(i + 1))
Call CopytempPlayerData(mPlayer(i + 1), tempPlayer)
Else If (mPlayer(i + 1).score = mPlayer(i).score) Then
''' not sure about Comparison Operator in next condition
If (mPlayer(i + 1).lowestRank < mPlayer(i).lowestRank) Then
' swap
sorted = False
Call CopytempPlayerData(tempPlayer, mPlayer(i))
Call CopytempPlayerData(mPlayer(i), mPlayer(i + 1))
Call CopytempPlayerData(mPlayer(i + 1), tempPlayer)
End If
End If
or use a Sub procedure as follows (having in mind Local Variables in Sub Procedures):
If (mPlayer(i + 1).score > mPlayer(i).score) Then
swapPlayers
Else If (mPlayer(i + 1).score = mPlayer(i).score) Then
''' not sure about Comparison Operator in next condition
If (mPlayer(i + 1).lowestRank < mPlayer(i).lowestRank) Then
swapPlayers
End If
End If
' remaining script statements here
Sub swapPlayers
' swap
sorted = False
Call CopytempPlayerData(tempPlayer, mPlayer(i))
Call CopytempPlayerData(mPlayer(i), mPlayer(i + 1))
Call CopytempPlayerData(mPlayer(i + 1), tempPlayer)
End Sub
Recently I am trying to get the permutation of undetermined number of variables. For undetermined I mean I was aiming to create an input box for users to put in the number.
Start from simple. Originally I was aiming to get a 4 digits permutations with each digit have different number of variables, i.e. 1st digit can only be A,B,C,D; 2nd digit be E,F; 3rd digit be G, H etc. Code are below:
Sub Permut()
Count = 1
For a = 1 To 4
For b = 1 To 2
For c = 1 To 2
For d = 1 To 2
For e = 1 To 2
'chr(97) is the alphabet "a"
Cells(Count, 1) = Chr(96 + a) & Chr(96 + Len(a) + b) & Chr(96 + Len(a) + Len(b) + c) & _
Chr(96 + Len(a) + Len(b) + Len(c) + d) & Chr(96 + Len(a) + Len(b) + Len(c) + Len(d) + e)
Count = Count + 1
Next
Next
Next
Next
Next
End Sub
This will give you 64 different combinations without repetition.
Just wondering is there a way to generalize this process so that people can choose how many variables in total as well as within each digit?
Thank you.
Here is a solution, where you would pass the Permut function the minimum value for each of the characters (digits) as one string, and the maximum characters also as a string. Both strings should have an equal number of characters of course:
Function Permut(min, max)
Dim str, nxt, count
str = min
count = 1
Do While str < max
Cells(count, 1) = str
count = count + 1
nxt = ""
For i = Len(str) To 1 Step -1
If Mid(str, i, 1) < Mid(max, i, 1) Then
nxt = ChrW(AscW(Mid(str, i, 1))+1) & nxt
Exit For
End If
nxt = Mid(min, i, 1) & nxt
Next
str = Left(str, Len(str) - Len(nxt)) & nxt
Loop
Cells(count, 1) = str
End Sub
You would call it like this:
Permut "abc", "bcf"
That example would produce this list on your sheet:
abc
abd
abe
abf
acc
acd
ace
acf
bbc
bbd
bbe
bbf
bcc
bcd
bce
bcf
How to Execute This with User Input and Button Click
If you want to call this code in response to an event, such as a button click, and want to pass it the contents of two cells where the user would first enter the min and max strings, then follow these steps:
Place an ActiveX command button on your sheet (put it somewhere in D1 to leave room for some other stuff)
Double click it to generate the empty click event handler. If that does not work, go to the code window and select the name of the button from the drop-down at the top of the window, and select Click from the next drop down.
Complete the code of that event handler as follows (I assume the button is called CommandButton1, but don't change the generated name):
Code:
Private Sub CommandButton1_Click()
Permut Range("B1"), Range("C1")
End Sub
This code assumes the user has to enter the min and max digits/characters in cells B1 and C1. The A column is of course reserved for the output of the code.
For a more complete explanation on how to add a command button and attach code to its click event, read "Add a command button (ActiveX control)" in the Office manual.
credit to the answer from trincot above.
I have tried to run the code with a bit modification coz I am not sure how to get set value into cells (0,1). It keeps saying error. But If I change the starting point to Cells(1,1) then I will miss the last permutation. So I just add an additional if statement to get the code work as I want.
Function Permut(min, max)
Dim str, nxt, count
str = min
count = 1
Do While str < max
Cells(count, 1) = str
count = count + 1
nxt = ""
For i = Len(str) To 1 Step -1
If Mid(str, i, 1) < Mid(max, i, 1) Then
'asc("a")=97; chr(97) ="a"
nxt = Chr(AscW(Mid(str, i, 1)) + 1) & nxt
Exit For
End If
nxt = Mid(min, i, 1) & nxt
Next
str = Left(str, Len(str) - Len(nxt)) & nxt
If str = max Then
Cells(count, 1) = str
End If
Loop
End Function
dim a(100)
a(0)=9,a(1)=3,a(2)=-3,a(3)=8,a(4)=2
how can i find size of used array(i.e used size is 5
You have to count the non-empty elements:
Option Explicit
Function UsedElms(a)
UsedElms = 0
Dim i
For i = 0 To UBound(a)
If Not IsEmpty(a(i)) Then UsedElms = UsedElms + 1
Next
End Function
Dim a(5)
a(2) = 2
a(4) = 4
WScript.Echo "ub:", UBound(a), "sz:", UBound(a) + 1, "us:", UsedElms(a)
output:
cscript 23027576.vbs
ub: 5 sz: 6 us: 2
Here's a hacky one-liner that I just thought of. It essentially counts the number of empty elements by converting them to spaces and then trimming them off.
intLastIndex = UBound(a) - Len(Join(a, " ")) + Len(Trim(Join(a, " ")))
Just for fun! Don't go putting it into your production code. It would certainly be more efficient as a two-liner:
s = Join(a, " ")
intLastIndex = UBound(a) - Len(s) + Len(Trim(s))
Ekkehard has the proper answer here, though. This hack only works if your array is filled contiguously.