I have a column in excel full of numbers, like this:
1
A 100
B 200
C 300
D 400
E 500
F 600
G 700
H 800
I 900
J 1000
K 1100
etc
etc
I formatted the column with a macro so that it highlights the top 10 %. Unfortunately, I have to work with it now, as in I have to have a piece of code that says: ok, grab the first cell that is in the top 10 % (say it's K1). Get K1 and copy it somewhere else.
Question:
How do I point to an element in the top 10 %? How do I tell VBA "Grab the first top 10% value (K1), then grab that second top 10% value?
Many thanks
Copy Top 10% of values from each Column to a different Worksheet
Sub ProcessColumns()
Dim i As Integer, j As Integer, rowCount As Long
Dim minvalue As Double, largeValue As Double
Dim arr
With Worksheets("Source")
arr = Sheet1.UsedRange.Value
For j = 1 To UBound(arr, 2)
minvalue = WorksheetFunction.Percentile(.Columns(j), 0.9)
For i = 2 To UBound(arr, 1)
largeValue = WorksheetFunction.Large(.Columns(j), i - 1)
If largeValue >= minvalue Then
arr(i, j) = largeValue
rowCount = i
Else
Exit For
End If
Next
Next
End With
Worksheets("Target").Range("A1").Resize(rowCount, UBound(arr, 2)).Value = arr
End Sub
Related
I have crated an Array with 500 rows and 10 columns. I am trying to generate an array of Signal strength using the radar range equation. I want to detect two targets at two ranges and I am putting them in the array at a specific point. I have 2 If statements nested within 2 for loops. The for loops work properly, I can't figure out where my If statements are wrong though. All of the values are correct (Hence the msgboxs for the values)
I have tried moving the Signal(i, j) = 0 into an If statement but I wasn't sure how to set the bounds since it is at every other points besides row 50 and 250.
Sub Generate_Power_Amplitude()
'/////////////////////Basic Parameters////////////////////////////
'/////////////////////Step 1//////////////////////////////////////
' Input the parameters of the Radar Range Equation
TotalPower = 10000 '(Watts)
Gain = 3162.27766 '(35 dB of gain)
Wavelength = 0.3 '(meters)
RCS = 15 '(meters^2)
RangeToTarget = 35000 '(meters)
PulseWidth = 1.67 * 10 ^ -6 '(seconds)
Bandwidth = 6 * 10 ^ 5 '(Hertz)
RangeBins = 1 * 10 ^ 3 '(meters)
PRI = 1 * 10 ^ -4 '(seconds)
PRF = 1 * 10 ^ 4 '(Hertz)
PRIDistance = 60000 '(meters)
'//////////////////Targets/////////////////////////////////////////////
'//////////////////Step 2//////////////////////////////////////////////
' Define how many targets and their distance
Target1 = 25000 '(meters)
Target2 = 125000 '(meters)
'/////////////////Operations//////////////////////////////////////////
RadarRangeNumerator = TotalPower * Gain ^ 2 * Wavelength ^ 2 * RCS
RadarRangeDenomenator = (4 * 3.1415926) ^ 3 * RangeToTarget ^ 4
RelativePower = RadarRangeNumerator / RadarRangeDenomenator
PowerAmplitude = RelativePower ^ 0.5
RelativePower1 = RadarRangeNumerator / ((4 * 3.1415926) ^ 3 * Target1 ^ 4)
RelativePower2 = RadarRangeNumerator / ((4 * 3.1415926) ^ 3 * Target2 ^ 4)
PowerAmp1 = RelativePower1 ^ 0.5
PowerAmp2 = RelativePower2 ^ 0.5
Dim Signal(500, 10)
For i = 1 To 500
For j = 1 To 10
If i = 50 Then
Signal(50, j) = PowerAmp1
ElseIf i = 250 Then
Signal(250, j) = PowerAmp2
End If
Signal(i, j) = 0
Next j
Next i
MsgBox Signal(50, 1)
MsgBox Signal(250, 1)
End Sub
I got the msgboxes to give the right values and this is the new For Loop, there is a comment below, as I said I feel this will eventually break and if there is a right way to do this let me know.
Dim Signal(500, 10)
For i = 1 To 500
For j = 1 To 10
If i = 500 Then
Signal(50, j) = PowerAmp1
Signal(250, j) = PowerAmp2
End If
Signal(i, j) = 0
Next j
Next i
This may be too simple of an answer but it seems like you just need to loop using the Ubound and Lbound tools. Here's an example with your code where you set the limits based on the Array size:
Dim Signal(500, 10)
For i = Lbound(Signal,1) To Ubound(Signal,1)
For j = LBound(Signal,2) To UBound(Signal,2)
If i = Ubound(Signal,1) Then
'This part confuses me:
Signal(50, j) = PowerAmp1
Signal(250, j) = PowerAmp2
End If
Signal(i, j) = 0
Next j
Next i
If all you ever want to do is insert the values for 50 and 250 into an array, then you don't need to set all the values to zero. In VBA, all variable values are initialized to zero including elements of an array. So this will produce the exact same result as your code:
Dim Signal(1 To 500, 1 To 10)
Signal(50, j) = PowerAmp1
Signal(250, j) = PowerAmp2
And, by the way, notice that I'm specifically stating the dimension range of the array. VBA will default to a zero-based array -- meaning your definition produced an array from 0 to 500, i.e. 501 elements.
#PGSystemTester is exactly correct in relating your loop bounds directly to the array bounds. This is a very common practice and can save you lots of heartache later on.
Dim Signal(1 To 500, 1 To 10)
For i = LBound(Signal, 1) To UBound(Signal, 1)
For j = LBound(Signal, 2) To UBound(Signal, 2)
If i = 500 Then
Signal(50, j) = PowerAmp1
Signal(250, j) = PowerAmp2
End If
Signal(i, j) = 0
Next j
Next i
Your next step may be to calculate the power at a series of stepped ranges to each target. Keep in mind that to define a variable number of steps -- array elements in this case -- you'll have to use ReDim
Const RANGE_STEPS As Long = 1000
Dim Signal As Variant
ReDim Signal(1 To RANGE_STEPS, 1 To 10)
If you're using the UBound and LBound functions, your loop remains exactly the same.
I am new with VBA and trying to do a trinomial option pricing tree with parameters from -n to n defined. How can I rewrite my VBA function with a double loop to provide all output as it seems to only show the value of S. In the end I want to sum all values and discount them but I cannot get past my double loop providing only one output. If I put the MsgBox between k and i loop it returns nothing. Please can someone assist getting this to work as I don't have the hang of VBA yet.
Public Function LoopTest(S As Double, u As Double, n As Integer)
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim St() As Double
ReDim St(2 * n + 1)
For k = 0 To n Step 1
For i = -k To k Step 1
St(i, k) = S * u ^ i
Debug.Print St(i, k)
MsgBox ("DebugToPrint")
' Payoff(i,k) = Application.WorksheetFunction.Max((St(i,k) - 20), 0)
Next i
Next k
' For i from n to 2 step -1
' For j from 1 to n - 2
' Payoff(i - 1, j) = Payoff(i, j) + Payoff(i, j + 1) + Payoff(i, j + 2)
' Next i
' Next k
LoopTest = St()
End Function
How do I get output
k=0 St = S*u^0
k=1 St = S*u^-1 , St = S*u^0 , St = S*u^1
k=2 St = S*u^-2 , St = S*u^-1 , St = S*u^0 , St = S*u^1 , St = S*u^2
etc and then sum everything afterwards as output?
I'm not totally following the example but from the description it sounds like you're interested in a recursive process. It can be tricky and will leave you in an endless loop if you're not careful. Does this previous post help you? VBA recursive "For loops" Permutation?
Suppose in column Z with 200 rows, are my optimal averages.
Now I want a macro that generates n random integers between a and b inclusive (n <= 20) so that difference between the average of numbers generated with optimal average is in (-0.15,+0.15).
Example:
Z1:optimal average1=5.5
Z2:optimal average2=5.3
Z200:optimal average200=6.3
n=8
a=1; b=10
numbers of generated:
A1:H1)5-9-4-3-7-4-9-3
A2:H2)10-7-3-2-5-4-3-9
.
.
.
A200:H200)4-8-9-6-6-6-10-2
Here is a hit-or-miss approach (which is often the only viable way to get random numbers which satisfy additional constraints in an unbiased way):
Function RandIntVect(n As Long, a As Long, b As Long, mean As Double, tol As Double, Optional maxTries As Long = 1000) As Variant
'Uses a hit-or-miss approach to generate a vector of n random ints in a,b inclusive whose mean is
'within the tolerance tol of the given target mean
'The function raises an error if maxTries misses occur without a hit
Dim sum As Long, i As Long, j As Long
Dim lowTarget As Double, highTarget As Double 'targets for *sums*
Dim vect As Variant
lowTarget = n * (mean - tol)
highTarget = n * (mean + tol)
For i = 1 To maxTries
ReDim vect(1 To n)
sum = 0
j = 0
Do While j < n And sum + a * (n - j) <= highTarget And sum + b * (n - j) >= lowTarget
j = j + 1
vect(j) = Application.WorksheetFunction.RandBetween(a, b)
sum = sum + vect(j)
Loop
If j = n And lowTarget <= sum And sum <= highTarget Then
'Debug.Print i 'uncomment this line to see how many tries required
RandIntVect = vect
Exit Function
End If
Next i
'error if we get to here
RandIntVect = CVErr(xlErrValue)
End Function
This could be used as a worksheet array formula. The target means were in column I and in A2:H2 I entered =RandIntVect(8,1,10,I2,0.15) (with ctrl+shift+enter as an array formula) and then copied down:
Note that array formulas are volatile, so these numbers would be recalculated every time the worksheet is. You could use the function in VBA to place the numbers directly in the ranges rather than using the function as a worksheet formula. Something like:
Sub test()
Dim i As Long
For i = 1 To 3
Range(Cells(i + 1, 1), Cells(i + 1, 8)).Value = RandIntVect(8, 1, 10, Cells(i + 1, 9).Value, 0.15)
Next i
End Sub
enter image description here
The difference between two means is not within range (0.15+, 0.15-)
So, I made a fun and simple macro that randomly selects R, G, and B values until it uses every possible combination (skipping repeats), and setting the color values of a 10x10 square with each new color.
The only problem is that I have run into the limit for the number of cell formats. Microsoft says that the limit should be around 64000, but I found it to be exactly 65429 on a blank workbook in Excel 2013.
I've included a clear format code, but it seems to have no effect:
Cells(X, Y).ClearFormats
Microsoft lists some resolutions, but 3 out of the 4 of them are essentially "Don't make too many formats", and the 4th format is to use a third party application.
Is there really nothing that can be done in VBA?
A1:J10 will print a new color
K1 will print the percentage to completion
L1 will print the number of colors used
M1 will print the number of times a color combination is repeated
Dim CA(255, 255, 255) As Integer
Dim CC As Long
Dim RC As Long
Dim R As Integer
Dim G As Integer
Dim B As Integer
Dim X As Integer
Dim Y As Integer
CC = 0
RC = 0
X = 1
Y = 1
Do While ColorCount < 16777216
R = ((Rnd * 256) - 0.5)
G = ((Rnd * 256) - 0.5)
B = ((Rnd * 256) - 0.5)
If CA(R, G, B) <> 1 Then
CA(R, G, B) = 1
'Step down to the next row
'If at the 10th row, jump back to the first and move to the next column
If X < 10 Then
X = X + 1
Else
X = 1
If Y < 10 Then
Y = Y + 1
Else
Y = 1
End If
End If
Cells(X, Y).ClearFormats 'doesn't do what I hope :(
Cells(X, Y).Interior.Color = RGB(R, G, B)
CC = CC + 1
Cells(1, 11).Value = (CC / 16777216) * 100
Cells(1, 12).Value = CC
Else
RC = RC + 1
Cells(1, 13).Value = RC
End If
Loop
There are several ways to resolve this issue, but the cleanest and easiest method is to remove all extra styles (I have seen workbooks with 9000+ styles )
With the following simple VBA code you can remove all non-builtin styles and in the vast majority of cases this fixes the error.
Sub removeStyles()
Dim li as long
On Error Resume Next
With ActiveWorkbook
For li = .Styles.Count To 1 Step -1
If Not .Styles(li).BuiltIn Then
.Styles(li).Delete
End If
Next
End With
End Sub
I have two sets of data that need to be matched based on IDs and timestamp (+/- 3 units converted from time), and below is the formula that I've been using in Excel to do the matching. Recently I've had to run this formula on up to 1 million rows in Excel, and it takes a REALLY long time, crashes too. I'm wondering if there is a faster way to do this, if not in Excel?
=INDEX(A:A,MATCH(1,--(B:B=E3)*--(ABS(C:C-F3)<=3),0),1)
Data Set 1:
Column A: States
Column B: IDs
Column C: Timestamp
Data Set 2:
Column D: Email Addresses
Column E: IDs
Column F: Timestamp
Column G: =INDEX(A:A,MATCH(1,--(B:B=E3)*--(ABS(C:C-F3)<=3),0),1)
Goal: Append "States" Column to Data Set 2 matched on IDs and Timestamp (+/- 3 time units) match.
Just don't know how to run this formula on very large data sets.
Place the following VBA routines in a standard code module.
Run the MIAB1290() routine.
This emulates the precise outcome of your INDEX/MATCH formula, but it is much more efficient. On my computer, a million records are correctly correlated and the results displayed in Column G in just 10 seconds.
Public Sub MIAB1290()
Dim lastB&, k&, e, f, z, v, w, vErr, r As Range
With [a2]
Set r = .Resize(.Item(.Parent.Rows.Count - .Row + 1, 5).End(xlUp).Row - .Row + 1, .Item(, .Parent.Columns.Count - .Column + 1).End(xlToLeft).Column - .Column + 1)
lastB = .Item(.Parent.Rows.Count - .Row + 1, 2).End(xlUp).Row - .Row + 1
End With
With r
.Worksheet.Sort.SortFields.Clear
.Sort Key1:=.Item(1, 2), Order1:=1, Key2:=.Item(1, 2), Order2:=1, Header:=xlYes
v = .Value2
End With
ReDim w(1 To UBound(v), 1 To 1)
vErr = CVErr(xlErrNA)
For k = 2 To UBound(v)
e = v(k, 5)
f = v(k, 6)
w(k, 1) = vErr
z = BSearch(v, 2, e, 1, lastB)
If z Then
Do While v(z, 2) = e
If Abs(v(z, 3) - f) <= 3 Then
w(k, 1) = v(z, 1)
Exit Do
End If
z = z + 1
If z > UBound(v) Then Exit Do
Loop
End If
Next
r(1, 8).Resize(r.Rows.Count) = w
End Sub
Private Function BSearch(vA, col&, vVal, ByVal first&, ByVal last&)
Dim k&, middle&
While last >= first
middle = (last + first) / 2
Select Case True
Case vVal < vA(middle, col)
last = middle - 1
Case vVal > vA(middle, col)
first = middle + 1
Case Else
k = middle - 1
Do While vA(k, col) = vA(middle, col)
k = k - 1
If k > last Then Exit Do
Loop
BSearch = k + 1
Exit Function
End Select
Wend
BSearch = 0
End Function
Excel isn't really made for large ammount of data, and probably no code will do it faster for you then a builtin excel formula. In this case, I would sugest you to give a try to the PowerPivot addin, and see how it handles the situation.