could I get help, I am trying to write data into cells in a spread sheet, using an initial value, then adding a specific increment until it reaches a maximum value also specified. I have included an example below. Thank you.
Min: 0.5
Max: 1.5
Increment: 0.1
wrote the code below, but it runs infinitely...
sub IncrementValue()
Dim iMin, iMax, inc, x As Single
iMin = Range("A1").Value
iMax = Range("A2").Value
Inc = Range("A3").Value
Range("B1").Value = iMin
x = 1
Do
x = x + 1
Range("B" & x).Value = Range("B" & x - 1).Value + Inc
Loop Until Range("B" & x).Value = iMax
End Sub
Sub FillIncrementingSeries(rStart As Range, dMin As Double, dMax As Double, dIncr As Double)
rStart.Value = dMin
rStart.Resize(((dMax - dMin) / dIncr) + 1, 1).DataSeries xlColumns, xlDataSeriesLinear, , dIncr, dMax
End Sub
Related
I have a two 1x345 arrays with historical price and storage data. While I can calculate the correlation coefficient manually for the entire arrays I want to calculate a number of correlation coefficients for different time offsets. (Basically what is the coefficient if I lag one array 1 week, 2 weeks, etc.) To achieve this I wrote a simple VBA script that (hopefully!) correlates a "lagged" B column against a static A column. Currently however the macro is only returning values of 0, 1, or -1 which are obviously incorrect.
Any ideas on why the CORREL function is kicking out those rounded answers?
Sub cor()
Dim i As Long, Astart As Long, Aend As Long
Dim Bstart As Long, Bend As Long
Dim cor As Long, offset As Long
For i = 2 To 346
offset = Cells(i, 3).Value
Astart = 2
Aend = 346 - offset
Bstart = 2 + offset
Bend = 346
If Astart >= Aend Then
Exit For
End If
Set arng = Range("A" & Astart & ":A" & Aend)
Set brng = Range("B" & Bstart & ":B" & Bend)
cor = WorksheetFunction.Correl(arng, brng)
Cells(i, 4).Value = co
Next i
End Sub
Long is a 32-bit Integer type.
Depending on your precision needs you'll want to be using a Single or a Double instead, as Tim Williams indicated.
I have a table which goes from A1 to ALL1 (1000 values), I have to find the max value of consecutive numbers for example if I had these six values:
4 37 -12 2 3 -1, the max would be 41 taken from the first two numbers. If it was
-6 -14 6 15 22 -9, it would be 43 (from 6, 15, 22).
I have to do this in VBA from randomly generated numbers (figured that part out so it's good), but can't figure out this part and then I have to return the position of the first and last value in my sequence. So please some help would be greatly appreciated as I'm not quite a VBA wizard.
Thank you :)
Consider the below example:
Sub Test()
Dim arrValues() As Variant
Dim dblTop As Double
Dim lngFirst As Long
Dim lngLast As Long
Dim i As Long
Dim j As Long
Dim dblSum As Double
Dim arrResult() As Variant
arrValues = Range("A1:ALL1")
dblTop = arrValues(1, 1)
lngFirst = 1
lngLast = 1
For i = 1 To 1000
dblSum = 0
For j = i To 1000
dblSum = dblSum + arrValues(1, j)
If dblSum > dblTop Then
lngFirst = i
lngLast = j
dblTop = dblSum
End If
Next
Next
Debug.Print "Max value: " & dblTop
Debug.Print "First index: " & lngFirst
Debug.Print "Last index: " & lngLast
arrResult() = Array()
For k = lngFirst To lngLast
ReDim Preserve arrResult(UBound(arrResult) + 1)
arrResult(UBound(arrResult)) = arrValues(1, k)
Next
Debug.Print "Sequence: " & Join(arrResult, " + ")
End Sub
For the set of the values e. g. as in the question
It returns the following output
Just to be a little different, and because I did the work before my weekend blew up, here is a function that will return a range:
Function MAXSUM(r As Range) As Range
Dim i&, j&
Dim rng As Range
Dim sm As Double
Dim ws As Worksheet
Set ws = ActiveSheet
sm = r.Item(1) + r.Item(2)
For i = 1 To r.Cells.Count - 1
For j = i + 1 To r.Cells.Count
With ws
If WorksheetFunction.Sum(.Range(r(i), r(j))) > sm Then
Set rng = .Range(r(i), r(j))
sm = WorksheetFunction.Sum(.Range(r(i), r(j)))
End If
End With
Next j
Next i
Set MAXSUM = rng
The beauty of this is:
1.It returns the range of the max sum.
2.It is not dependent on being in the first row, it can be a column, a row, or multiples of each. It will look left to right first then top to bottom of the range.
3.It can be called from vba and/or directly as a UDF in the worksheet(see below)
To call from vba:
Sub getmax()
Dim rng As Range
Dim ws As Worksheet
Set ws = ActiveSheet
Set rng = MAXSUM(ws.Range("A1 :AAL1"))
Debug.Print rng.Address 'gets the address of range
Debug.Print WorksheetFunction.Sum(rng) 'gets the sum of the range
End Sub
This just shows a few things, but because it returns a range it is possible to do anything one can do with a given range.
To call from the worksheet directly:
To get the sum:
=SUM(MAXSUM(*YourRange*))
To get the range:
First Cell:
=ADDRESS(ROW(MAXSUM(*YourRange*)),COLUMN(MAXSUM(*YourRange*)))
Last cell:
=ADDRESS(ROW(MAXSUM(*YourRange*))+ROWS(MAXSUM(*YourRange*))-1,COLUMN(MAXSUM(*YourRange*))+COLUMNS(MAXSUM(*YourRange*))-1)
Full Address:
=ADDRESS(ROW(MAXSUM(*YourRange*)),COLUMN(MAXSUM(*YourRange*)))&":"&ADDRESS(ROW(MAXSUM(*YourRange*))+ROWS(MAXSUM(*YourRange*))-1,COLUMN(MAXSUM(*YourRange*))+COLUMNS(MAXSUM(*YourRange*))-1)
Basically the formula MAXSUM(*YourRange*) works like a named range, and anything you can do with a named range you can do with this.
One note: This currently assumes that the user wants the sum of at least two numbers and therefore if the entire range is negative, or only one consecutive positive it will return the sum of the two consecutive cells that give the highest sum. To make it so it will return the highest one cell in the case of all negative or only one consecutive positive cells then remove the +1 and -1 from the beginning of the for loops.
This will do it:
Sub msa()
Dim j&, cur&, max&, ndx&, ndx1&, ndx2&, a: ndx = 1
a = [A1:ALL1]
For j = 1 To UBound(a, 2)
cur = cur + a(1, j)
Select Case True
Case cur > max: max = cur: ndx2 = j: ndx1 = ndx
Case cur <= 0: cur = 0: ndx = j + 1
End Select
Next
MsgBox max & vbLf & ndx1 & vbLf & ndx2
End Sub
My answer is based on Kadane's algorithm which has a time complexity of O(n), which is dramatically more efficient than the brute force O(n*n) time complexity of the other answer.
.
UPDATE
To handle the edge case of all negative numbers as well, you can use this version:
Sub msa()
Dim j&, k&, m&, n&, cur&, max&, ndx&, ndx1&, ndx2&, a: ndx = 1: m = -2 ^ 31
a = [A1].CurrentRegion.Resize(1)
For j = 1 To UBound(a, 2)
k = a(1, j)
If k > m Then m = k: n = j
cur = cur + k
Select Case True
Case cur > max: max = cur: ndx2 = j: ndx1 = ndx
Case cur <= 0: cur = 0: ndx = j + 1
End Select
Next
If max = 0 Then max = m: ndx1 = n: ndx2 = n
MsgBox max & vbLf & ndx1 & vbLf & ndx2
End Sub
I am wondering how I can write a VBA code to check if my data crosses over a certain point of interest. I have a column of approx. 40,000 data points that linearly increase and decrease (i.e 0 to 10 and then back down from 10 to 0). I want to identify when the points cross over a value and perform interpolation on corresponding data values. For example, I would like to write a code that will pick every time my data set crosses 4.1, and perform interpolation on the corresponding cell values in another column.
This is what I have tried so far
'Calculate how many data points are present in worksheet
Dim lastRow As Long
lastRow = Range("B" & Rows.Count).End(xlUp).Row
'Identify the data colum as pot1 throughout code
Set pot1 = Range("N14:N" & lastRow)
Dim i As Integer
'data starts from line 14 of worksheet
For i = 14 To lastRow
'check to see if the cell above contains text, if it does, line a tells it to skip that cell and move to next one
If WorksheetFunction.IsNumber(Cells(i - 1, 2)) = False Then GoTo a
a:
i = i + 1
GoTo b
'check if two vertically adjacent cells have crossed over 4.1
b:
If Cells(i, 2) > 3.995 & Cells(i + 1, 2) < 4.01 Then
' interpolate the value if they have crossed 4.1
Range("S1")=WorksheetFunction.Forecast(4.1, Cells(i:i+1,2), Range("D" i ":D" i+1)
I am stuck at using forecast function as I currently don't know how I can tell excel to pick a block of cells inside a loop.
Here's how you would do the looping:
Sub Tester()
Dim sht As Worksheet, lastRow As Long, xvals, yvals, r As Long
Dim th As Double, y1, y2, x1, x2
Set sht = ActiveSheet
lastRow = sht.Range("B" & Rows.Count).End(xlUp).Row
'assumes y vals in "B" and x vals in "N"
'adjust as rtequired...
yvals = sht.Range(sht.Cells(14, "B"), sht.Cells(lastRow, "B"))
xvals = sht.Range(sht.Cells(14, "N"), sht.Cells(lastRow, "N"))
th = 4.1
For r = 1 To UBound(yvals) - 1
y1 = yvals(r, 1)
y2 = yvals(r + 1, 1)
'pair of points crosses the threshold?
If IsNumeric(y1) And IsNumeric(y2) Then
If (y1 < th And y2 > th) Or (y1 > th And y2 < th) Then
x1 = xvals(r, 1)
x2 = xvals(r + 1, 1)
'*************
'calculate the intercept
'*************
End If
End If
Next r
End Sub
First of all, you forgot & in your forecast formula :
Range("S1")=Worksheetfunction.Forecast(4.1, , Range("D" & i ":D" & i+1)
Secondly, Forecast function requires three arguments - you only provide two of them. Please take a look here for more info on Forecast function.
There are a few problems with this statement:
Range("S1")=WorksheetFunction.Forecast(4.1, Cells(i:i+1,2), Range("D" i ":D" i+1)
The main problem is you are calling the ranges wrong
Cells(i:i+1,2)
Should be:
Range(Cells(i,2),Cells(i+1,2))
or
Range("B" & i & ":B" & i + 1)
See above for why Range("D" i ":D" i+1) is also wrong.
You also are missing a ')' At the end of the statement.
So Adding it all together:
Range("S1")=WorksheetFunction.Forecast(4.1, Range("B" & i & ":B" & i + 1), Range("D" & i & ":D" & i+1))
What I am trying to do is develop a model that takes a cell that is greater than 1 then to take the sum of the area to the first row using a cone shape, so for example cell D4, sum the area C3:C5 + B2:B6 + A1:A7.
At the moment I have this but it obviously is not working.
Dim I As Double
Dim J As Double
Dim Size As Integer
Dim x As Integer
Dim y As Integer
Dim z As Integer
'Dim Range As Integer
Dim PV1 As Integer
'MCArray = Worksheets("Data")
I = WorksheetFunction.CountA(Worksheets("Data").Rows(1))
J = WorksheetFunction.CountA(Worksheets("Data").Columns(1))
'Loop to Move down the rows
For x = 1 To J
'Loop to move acoss the columns
For y = 1 To I
'IfElse to determine if cell value is greater or equal to zero
If Cells(J, I).Value >= 0 Then
'Loop to sum the cells above
For z = 1 To J
PV1 = (ActiveCell.Value) + Worksheet.Sum(Range([J - z], [I-z:I+z]))
'IfElse to determine if final sum is greater than zero
If PV1 > 0 Then
Worksheets("MC").Range("B4").Value = PV1
Range([J - z], [I-z:I+z]).Interior.ColourIndex = 1
End If
Next z
End If
Next y
Next x
Here is a function you can use either as a UDF or from another routine. Just pass it the single cell you want to start from (D4 in your example) and this function will calculate the sum of the cone as you described.
Public Function SUMCONE(r As Range) As Double
Application.Volatile
SUMCONE = Application.Sum(r, r(-0, -0).Resize(, 3), r(-1, -1).Resize(, 5), r(-2, -2).Resize(, 7))
End Function
Here is an example of how to use the above function from your VBA routine:
Public Sub Demo()
Dim j&
For j = 5 To 10
If Cells(5, j) > 0 Then
Debug.Print SUMCONE(Cells(5, j))
End If
Next
End Sub
UPDATE
Based on your feedback I have updated the function and the demo routine to form an upward cone summation from the initial cell.
UPDATE #2
The above is for a fixed-size cone, extending upwards, that can be initiated from any cell in the worksheet.
But if you would prefer for the cone to always extend all the way up to row 1 regardless of which cell it originates in, then the following is what you are after:
Public Sub Demo()
Dim i&, j&
For j = 1 To Application.CountA(Worksheets("Data").Rows(1))
For i = 1 To Application.CountA(Worksheets("Data").Columns(1))
If Cells(i, j) > 0 Then
Debug.Print Cells(i, j).Address, SumAndColorCone(Cells(i, j))
End If
Next
Next
End Sub
Public Function SumAndColorCone(r As Range) As Double
Dim i&, k&, c As Range
Set c = r
For i = r.Row - 1 To 1 Step -1
Set c = Union(c, r(-k, -k).Resize(, (k + 1) * 2 + 1))
k = k + 1
Next
c.Interior.Color = vbRed
SumAndColorCone = Application.Sum(c)
End Function
UPDATE #3
As I suspected there was a problem if the cone was initiated too close to the left edge of the worksheet. I've added code to handle that now. Also your method for accessing the large matrix (which I had used in the Demo routine) did not work properly. I fixed that as well:
Public Sub Demo()
Dim i&, j&
For j = 1 To Cells(1, Columns.Count).End(xlToLeft).Column
For i = 1 To Cells(Rows.Count, "A").End(xlUp).Row
If Val(Cells(i, j)) > 0 Then
Debug.Print Cells(i, j).Address, SumAndColorCone(Cells(i, j))
End If
Next
Next
End Sub
Public Function SumAndColorCone(r As Range) As Double
Dim i&, k&, c As Range
Set c = r
For i = r.Row - 1 To 1 Step -1
If r.Column - k < 2 Then Exit For
Set c = Union(c, r(-k, -k).Resize(, (k + 1) * 2 + 1))
k = k + 1
Next
c.Interior.Color = vbRed
SumAndColorCone = Application.Sum(c)
End Function
I am trying to sum up all of the random integer values over 500 and then present them in a text box, however it is not working and whenever I run the code, it sums to zero. This is inside of a user form using VBA. Any suggestions would be appreciated.
Private Sub CommandButton1_Click()
Dim r As Double, c As Double, rand As Double, y As Double, x As Double, i As Double
r = TextBox1.Value
c = TextBox2.Value
rand = TextBox3.Value
Rnd [5]
i = 0
For x = 1 To r
For y = 1 To c
Cells(x, y).Value = Int(Rnd * rand)
If (ActiveCell.Value >= 500) Then
i = i + ActiveCell.Value
Else ' do nothing
End If
Next y
Next x
Cells(r + 1, c).Value = "SUM"
Cells(r + 1, c + 1).Value = i
MsgBox (i)
End Sub
I don't know much about VBA, but could
Cells(x, y).Value = Int(Rnd * rand)
If (ActiveCell.Value >= 500) Then
.. be referring to different cells?