Related
I'm trying to generalize the algorithm Paul Hankin provided in Maximizing the overall sum of K disjoint and contiguous subsets of size L among N positive numbers such that the solution is not limited to each subset being exactly size L and where the goal is not to maximize the overall sum, but to return the set with the largest subsets possible.
Spelling out the details, X is a set of N positive real numbers:
X={x[1],x[2],...x[N]} where x[j]>=0 for all j=1,...,N.
A contiguous subset called S[i] consists of up to L consecutive members of X starting at position n[i] and ending at position n[i]+l-1:
S[i] = {x[j] | j=n[i],n[i]+1,...,n[i]+l-1} = {x[n[i]],x[n[i]+1],...,x[n[i]+l-1]}, where l=1,...,L.
Two of such subsets S[i] and S[j] are called pairwise disjoint (non-overlapping) if they don't contain any identical members of X.
Define the summation of the members of each subset:
SUM[i] = x[n[i]]+x[n[i]+1]+...+x[n[i]+l-1]
The goal is find contiguous and disjoint (non-overlapping) subsets S[1],S[2],... of lengths ranging from 1 to L that are as large as possible and cover all N elements of X.
For example, given X = {5,6,7,100,100,7,8,5,4,4} and L = 4, the solution is S[1] = {5,6,7}, S[2] = {100, 100, 7, 8}, and S[3] = {5,4,4} such that SUM[1] = 18, SUM[2] = 215, and SUM[3] = 13. While the overall sum, no matter the subsets, will always be 246, the key is that no other subsets with lengths ranging from 1 to L will produce larger SUM[i], than those provided above.
Any help is greatly appreciated.
I'll clean up the code later, but here's the solution I came up with.
Sub getLargestEvents()
'Algorithm adapted from Maximizing the overall sum of K disjoint and contiguous subsets of size L among N positive numbers
Dim X As Variant
Dim N As Integer
Dim sumOfX As Integer
Dim L As Integer
Dim S As Variant
Dim subsetOfXforS As Variant
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim SUM As Variant
Dim sumOfM As Integer
Dim numberOfEvents As Integer
Dim M As Variant
Dim maxSUM As Integer
Dim maxI As Integer
Dim maxJ As Integer
Dim beginningSUM As Variant
Dim endingSUM As Variant
'X is the array of N losses (sorted) by day
X = Array(5, 6, 7, 100, 100, 7, 8, 5, 4, 4, 100, 100, 4, 5, 6, 7, 8)
'N is the number of days of loss in the array X
N = UBound(X)
For i = 0 To N
sumOfX = sumOfX + X(i)
Next i
'L is the hours clause expressed in days (i.e., L = hours clause / 24)
L = 4
'S is the jagged array of N * ( L - 1 ) subsets of X containing no more than L contiguous days of loss
ReDim S(N, L - 1)
'subsetOfXforS is the array of L - 1 days of X containing j contiguous days of loss and is used to create the jagged array S
ReDim subsetOfXforS(L - 1)
For i = 0 To N
For j = 0 To L - 1
If i >= j Then
For k = 0 To j
Debug.Print X(i - j + k)
subsetOfXforS(k) = X(i - j + k)
Next k
End If
S(i, j) = subsetOfXforS
Next j
Next i
'SUM is the array of summations of the members of S
ReDim SUM(N, L - 1)
For i = 0 To N
For j = 0 To L - 1
If i >= j Then
For k = 0 To UBound(S(i, j))
If j >= k Then
Debug.Print "S(" & i & ", "; j & ")(" & k & ") = " & S(i, j)(k)
SUM(i, j) = SUM(i, j) + S(i, j)(k)
Debug.Print "SUM(" & i & ", "; j & ") = " & SUM(i, j)
End If
Next k
End If
Next j
Next i
beginningSUM = SUM
ReDim M(N, 2)
endingSUM = SUM
Do While sumOfM < sumOfX
maxSUM = 0
'Determine max value in current array
For i = 0 To N
For j = 0 To L - 1
If i >= j Then
If beginningSUM(i, j) > maxSUM Then
maxSUM = SUM(i, j)
maxI = i
maxJ = j
End If
Debug.Print "beginningSUM(" & i & ", " & j & ") = " & beginningSUM(i, j)
End If
Next j
Next i
sumOfM = sumOfM + maxSUM
'Store max value
M(numberOfEvents, 0) = maxI
M(numberOfEvents, 1) = maxJ
M(numberOfEvents, 2) = maxSUM
Debug.Print "maxI: " & maxI & ", maxJ: " & maxJ & ", maxSUM: " & maxSUM
'Remove values that can no longer apply
For i = 0 To N
For j = 0 To L - 1
If i >= j Then
If (maxI - maxJ <= i And i <= maxI) Or (maxI < i And i - j <= maxI) Then
endingSUM(i, j) = 0
Debug.Print "endingSUM(" & i & ", " & j & ") = " & endingSUM(i, j) & " <- removed"
Else
endingSUM(i, j) = beginningSUM(i, j)
Debug.Print "endingSUM(" & i & ", " & j & ") = " & endingSUM(i, j)
End If
End If
Next j
Next i
beginningSUM = endingSUM
numberOfEvents = numberOfEvents + 1
Loop
Debug.Print "Final Event Set"
For a = 0 To numberOfEvents - 1
Debug.Print "i: " & M(a, 0) & ", j: " & M(a, 1) & ", M: " & M(a, 2)
Next a
End Sub
Here's a better solution:
Sub getLargestEvents()
'Algorithm adapted from http://stackoverflow.com/questions/29268442/maximizing-the-overall-sum-of-k-disjoint-and-contiguous-subsets-of-size-l-among
Dim N As Long 'limit of +2,147,483,647
Dim X As Variant
Dim i As Long
Dim L As Integer
Dim S As Variant
Dim j As Integer
Dim tempS As Variant
Dim largestEvents As Variant
Dim numberOfEvents As Long
Dim sumOfM As Double
Dim maxSUM As Double
Dim maxI As Long
Dim maxJ As Long
X = Array(5, 6, 7, 100, 100, 7, 8, 5, 4, 4, 100, 100, 4, 5, 6, 7, 8)
'N is the number of days of loss in the array X
N = UBound(X)
'L is the hours clause expressed in days (i.e., L = hours clause / 24)
L = 4
'S contains the sums of all events that contain no more than L contiguous days of loss
ReDim S(L * N, L)
'Debug.Print "i, j, S(i, j):"
For i = 1 To N
For j = 1 To L
If i >= j Then
S(i, j) = X(i) + S(i - 1, j - 1)
'Debug.Print i & ", " & j & ", " & S(i, j)
End If
Next j
Next i
tempS = S
ReDim largestEvents(N, 3)
Do While WorksheetFunction.SUM(S) > 0
maxSUM = 0
numberOfEvents = numberOfEvents + 1
'Determine max value in current array
For i = 1 To N
For j = 1 To L
If i >= j Then
If tempS(i, j) > maxSUM Then 'tempS(i, j) > maxSUM Then
maxSUM = S(i, j)
maxI = i
maxJ = j
End If
'Debug.Print "tempS(" & i & ", " & j & ") = " & tempS(i, j)
End If
Next j
Next i
sumOfM = sumOfM + maxSUM
'Store max value
largestEvents(numberOfEvents, 1) = maxI
largestEvents(numberOfEvents, 2) = maxJ
largestEvents(numberOfEvents, 3) = maxSUM
'Debug.Print "maxI: " & maxI & ", maxJ: " & maxJ & ", maxSUM: " & maxSUM
'Remove values that can no longer apply
For i = 1 To N
For j = 1 To L
If i >= j Then
If (maxI - maxJ < i And i <= maxI) Or (maxI < i And i - j < maxI) Then
tempS(i, j) = 0
'Debug.Print "tempS(" & i & ", " & j & ") = " & tempS(i, j) & " <- removed"
End If
End If
Next j
Next i
S = tempS
Loop
Debug.Print "Start Date, Length, Amount"
For i = 1 To numberOfEvents
Debug.Print "start date: " & largestEvents(i, 1) - largestEvents(i, 2) + 1 & ", length: " & largestEvents(i, 2) & ", amount: " & largestEvents(i, 3)
Next i
End Sub
Function getUserSelectedRange(description As String) As Range
'Code adapted from
'http://stackoverflow.com/questions/22812235/using-vba-to-prompt-user-to-select-cells-possibly-on-different-sheet
Set getUserSelectedRange = Application.InputBox("Select a range of " + description, "Obtain Range Object", Type:=8)
End Function
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.
I'm trying to create a method converting a number to normalized scientific notation, here is the code that I'm using to calculate mantissa and exponent:
ConvNSN 1000, M, P
MsgBox M & "e" & P
Sub ConvNSN(N, M, P)
If N = 0 Then
P = 0
M = 0
Else
P = Int(Log(Abs(N)) / Log(10))
M = N / 10 ^ P
End If
End Sub
The problem I am facing is that this code gives wrong exponent value for some numbers, eg 1000, 10E+6, 10E+9, 10E+12, 10E+13, etc... Exactly for 1000 converted should be 1e3, but not 10e2. It's obvious that the same problem with numbers, whose logarithms are close to an integer value, like Log(1 - 5.55111512312578E-17) / Log(10), which result is 0, however 1 - 5.55111512312578E-17 less then 1, and result has to be negative.
How can I get rid of Double type imprecision, and get this code to work properly?
UPDATE
I assume the fastest and quite accurate method to calculate mantissa and exponent of number in normalized scientific notation may be as follows:
Sub ConvNSN(N, M, P)
Dim A
If N = 0 Then
P = 0
M = 0
Exit Sub
End If
A = Abs(N)
If A < 1 Then
P = Int(Log(A) / Log(10))
Else
P = Int(Log(A) / Log(10) * (2 + Log(.1) / Log(10)))
End If
M = N / 10 ^ P
End Sub
Or another one, based on #Bob's solution:
Sub ConvNSN(N, M, P)
If N = 0 Then
P = 0
M = 0
Else
P = Int(Log(Abs(N)) / Log(10))
M = N / 10 ^ P
End If
If Abs(M) = "10" Then
M = M / 10
P = P + 1
End If
End Sub
First one slightly faster. Both of them process exponent from -322 to 308, but return not normalized mantissa with powers of 10 less then -310. I have not tested them yet with numbers, whose logarithms are a marginally less but very close to an integer values.
UPDATE 2
I decided to attach here an extra Sub ConvEN(), allowing to represent a number in engineering notation with SI prefixes from "p" to "T":
N = .0000456789
ConvNSN N, M, P
M = Round(M, 2)
ConvEN M, P, R, S
MsgBox R & " " & S & "Units"
Sub ConvNSN(N, M, P)
Dim A
If N = 0 Then
P = 0
M = 0
Exit Sub
End If
A = Abs(N)
If A < 1 Then
P = Int(Log(A) / Log(10))
Else
P = Int(Log(A) / Log(10) * (2 + Log(.1) / Log(10)))
End If
M = N / 10 ^ P
End Sub
Sub ConvEN(M, P, R, S)
DIM Q, P3
Q = int(P / 3)
P3 = Q * 3
If Q >= -4 And Q <= 4 Then
S = Array("p", "n", ChrW(&H03BC), "m", "", "k", "M", "G", "T")(Q + 4)
Else
S = "e" & P3 & " "
End If
R = M * 10 ^ (P - P3)
End Sub
Try this:
ConvNSN 1000, M, P
MsgBox M & "E" & P
ConvNSN 0.00000000000000001234, M, P
MsgBox M & "E" & P
ConvNSN -0.00000000000000001234, M, P
MsgBox M & "E" & P
Sub ConvNSN(N, M, P)
P = 0
If N < 0 Then
S = -1
ElseIf N > 0 Then
S = 1
Else
M = 0
Exit Sub
End If
M = Abs(N)
If M >= 10 Then
While M >= 10
M = M / 10
P = P + 1
Wend
M = M * S
Exit Sub
End If
If M < 1 Then
While M < 1
M = M * 10
P = P - 1
Wend
M = M * S
Exit Sub
End If
End Sub
Based on the comments, I re-wrote this my way, ignoring the structure from the OP.
MsgBox NSN(-0.0000000000000000000123456789,4)
MsgBox NSN(1234567890000000000000000000,4)
Function NSN(Number, Accuracy)
Exponent = 0
If Number > 0 Then
Sign = 1
ElseIf Number < 0 Then
Sign = -1
Else
NSN = 0
Exit Function
End If
Number = Number * Sign
If Number >= 10 Then
While Number >= 10
Number = Number / 10
Exponent = Exponent + 1
Wend
ElseIf Number < 1 Then
While Number < 1
Number = Number * 10
Exponent = Exponent - 1
Wend
End If
Number = Round(Number, Accuracy)
If Number = "10" Then
Number = 1
Exponent = Exponent + 1
End If
Number = Number * Sign
If Exponent = 0 Then
NSN = Number
Else
NSN = Number & "E" & Exponent
End If
End Function
Using strings rather than maths can help. Add your own error checking.
Num = "1000000.0005"
NumOfDigits = 4
Mag = Instr(Num, ".")
Num = Replace(Num, ".", "")
MSD = Left(Num, 1)
Rest = Mid(num, 2, NumOfDigits)
msgbox MSD & "." & Rest & " x 10^" & (Mag -2)
I'm developing a program in visual basic 6.0 to display magic square. I've developed the logic, but the values are not getting displayed in the magic square. Here's the code :
Private Sub Command1_Click()
Dim limit As Integer
Dim a(100, 100) As Integer
limit = InputBox("Enter the limit")
If limit Mod 2 = 0 Then ' Rows and columns must be
MsgBox "Can't be done", vbOKCancel, "Error"
Else ' set number of rows and columns to limit
mfgsquare.Rows = limit
mfgsquare.Cols = limit
j = (n + 1) / 2
i = 1
For c = 1 To n * n
mfgsquare.TextMatrix(i, j) = c
If c Mod n = 0 Then
i = i + 1
GoTo label
End If
If i = 1 Then
i = n
Else
i = i - 1
End If
If j = n Then
j = 1
Else
j = j + 1
End If
label:
Next c
End If
End Sub
Try this:
n = InputBox("Enter the limit")
If n Mod 2 = 0 Then ' Rows and columns must be
MsgBox "Can't be done"
Else ' set number of rows and columns to limit
mfgsquare.Rows = n + 1
mfgsquare.Cols = n + 1
For i = 1 To n
For j = 1 To n
mfgsquare.TextMatrix(i, j) = n * ((i + j - 1 + Int(n / 2)) Mod n) + ((i + 2 * j - 2) Mod n) + 1
Next j
Next i
End If
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