With some 20K observations, the following code takes some 7.5 sec to run
'Remember time when macro starts
StartTime = Timer
For i = 2 To UBound(avTransposed, 2)
For J = 1 To UBound(avTransposed, 1)
k = IIf(J = 1, k + 1, k)
' If J = 1 Then k = k + 1
ReDim Preserve TrueUsedRangeArray(1 To Dim2, 1 To k)
TrueUsedRangeArray(J, k) = avTransposed(J, i)
Next
Next
'Determine how many seconds code took to run
SecondsElapsed = Round(Timer - StartTime, 2)
Without the
k = IIf(J = 1, k + 1, k) line (or If J = 1 Then k = k + 1), it takes less than one sec!!
Any idea?
The ReDim Preserve is probably killing performance. Every time it is used, it creates a new array and copies the existing array in.
You can work out up-front the size of TrueUsedRangeArray, something like the following
ReDim TrueUsedRangeArray(1 To Ubound(avTransposed, 2), 1 To Ubound(avTransposed, 1))
Too many things in your inner loop which do not need to be there:
For i = 2 To UBound(avTransposed, 2)
k = k + 1
ReDim Preserve TrueUsedRangeArray(1 To Dim2, 1 To k)
For J = 1 To UBound(avTransposed, 1)
TrueUsedRangeArray(J, k) = avTransposed(J, i)
Next
Next
As Patrick notes though, you do not need the redim preserve in the loop, since you already know the final size of TrueUsedRangeArray from the dimensions of avTransposed
Related
Trying to use Gauss seidel method to solve a 25 by 25 matrix to solve a 2D heat transfer chemical engineering problem.
But it doesnt go to 2nd iteration
Do While error > 0.1
temps0 = temps1(UBound(matrix1, 1), 1) ' Old temperature for error calculation
'Conducts the gauss algorithm for each row
For i = 1 To UBound(matrix1, 1)
temps1(i, 1) = matrix1(i, UBound(matrix1, 2))
For j = 1 To (UBound(matrix1, 2) - 1)
If j <> i Then
temps1(i, 1) = temps1(i, 1) - (matrix1(i, j) * temps1(j, 1))
ElseIf j = i Then
divider = matrix1(i, j)
End If
Next j
temps1(i, 1) = temps1(i, 1) / divider
Next i
error = Abs((temps1(UBound(matrix1, 1), 1) - temps0) / temps1(UBound(matrix1, 1), 1))
iteration = iteration + 1
Loop
this is the do while loop for Gauss Seidel
Matrix1 is coeff matrix generated by previous functions
Really appreciate any help.
TY
I've been stuck here for hours trying to come up with a VBA excel logic for this problem. Think of this as a tree problem, in which the number of branches/nodes is determined by the user and inputted at the start.
For every node, there is 3 possible outcomes, staying flat, increasing by 1% or decreasing by 1%. i.e. for 5 nodes, you will get 5^3 nodes and so on...
How do i code this in vba so that it auto-populates the spreadsheet?
I am trying to model a population birth rate in a city where after every year, T+0 to T+n, where n is the number of nodes. So every +1 year, there could either be 101% of the population, 100% or 99% of the population remaining in the city.
To add to the complexity, the number of people in the city has to be dynamic at any time. So for example we know the path in the 5th year where we get +1% of population every year. so at 5th year we should have (1.01)^5 people. However, since this city is dynamic, there could be people leaving or entering the city, so manual adjustments to the city population has be to catered for.
E.G. At 5th year, 5000 left the city to another place. So the spreadsheet has to be dynamic enough to adjust the 5th level node from (1.01)^5 to (1.01)^5 - 5000. And the 6th node carries on from there.... branching out again.
Not sure if i explained this clearly enough. But this seems to be really hard to code with my amateur vba skills. Is this possible?
Also, the spreadsheet seems to crash when i simulate 10 levels and above
Sub test()
Dim startvalue As Double, levels As Integer, j As Long, i As Long, k As Long
Application.ScreenUpdating = False
startvalue = Sheets("Sheet1").Range("A2")
levels = Sheets("Sheet1").Range("B2")
Sheets("Sheet2").Activate
Cells.ClearContents
Range("A1") = startvalue
For j = 2 To levels
For k = Cells(Rows.Count, j - 1).End(xlUp).Row To 1 Step -1
If Cells(k, j - 1) <> "" Then
Rows(k + 1).Insert shift:=xlDown
Cells(k + 1, j) = Cells(k, j - 1).Value * 0.99
Cells(k, j) = Cells(k, j - 1).Value
Rows(k).Insert shift:=xlDown
Cells(k, j) = Cells(k + 1, j - 1).Value * 1.1
End If
Next k
Next j
End Sub
First and foremost, I'd suggest you store your results on internal memory, then display them on your spreadsheet once it's done. Inserting rows within a loop is a major performance killer.
As for the data structure, you could use a two-dimensional array storing the results of each year
e.g.
year 1 : array(1,1) to array(1,3)
year 2 : array(2,1) to array(2,9)
year 3 : array(3,1) to array(3,27)
...
Once this structure is valued, use a 2nd loop to display it on the spreadsheet "plainly", without the pain of inserting those lines everywhere
It goes like that
Dim values() As Long
Sub main()
Dim startvalue As Double, levels As Integer
Dim i, j, k As Long
startvalue = 2000
levels = 3
ReDim values(levels, 3 ^ levels)
' == Calculate pop evolution for every year ==
values(1, 1) = startvalue
For i = 2 To levels
k = 1
For j = 1 To 3 ^ (levels - 2)
values(i, k) = values(i - 1, j)
values(i, k + 1) = values(i - 1, j) * 0.99
values(i, k + 2) = values(i - 1, j) * 1.01
k = k + 3
Next j
Next i
' == Display in on spreadsheet ==
Sheets("Sheet2").Activate
For i = 1 To levels
Cells(4, i) = i
k = 1
For j = 1 To 3 ^ (i - 1)
Cells(4 + k, i) = values(i, k)
k = k + 1
Next j
Next i
End Sub
I have this bit of my code which takes like 90 % of the runtime.
There are about 8000 rows and information are stored in column A. This bit of code is splitting this information in the other columns.
It takes approximately 15 mins to run ( :O ).
Any suggestions on how to improve the performance ?
For i = 2 To Row_Number ' Loop for each row
If InStr(Cells(i, 1), "//") = 0 Then ' This means that if // appears somewhere in the text we delete all the rows (including this one) (see Else :) and stop the loop
j = 1
Do Until Mid(Cells(i, 1), j, 1) = ";"
j = j + 1
Loop
LongVIN = Mid(Cells(i, 1), 1, j - 1)
k = j
j = j + 1
Do Until Mid(Cells(i, 1), j, 1) = ";"
j = j + 1
Loop
Cells(i, 3) = Mid(Cells(i, 1), k + 1, j - k - 1) ' Model
k = j
j = j + 1
Do Until Mid(Cells(i, 1), j, 1) = ";"
j = j + 1
Loop
Cells(i, 4) = Mid(Cells(i, 1), k + 1, j - k - 1) ' Dealer
k = j
j = j + 1
Do Until Mid(Cells(i, 1), j, 1) = ";"
j = j + 1
Loop
k = j
j = j + 1
Do Until Mid(Cells(i, 1), j, 1) = ";"
j = j + 1
Loop
Cells(i, 6) = Mid(Cells(i, 1), k + 1, j - k - 1) ' Region
k = j
j = j + 1
Do Until Mid(Cells(i, 1), j, 1) = ";"
j = j + 1
Loop
Cells(i, 7) = CDate(Mid(Cells(i, 1), k + 1, j - k - 1)) ' Retail Date
k = j
Cells(i, 5) = Mid(Cells(i, 1), k + 1, Len(Cells(i, 1)) - k) '(Len - (k+1) +1) Dealer Name
Cells(i, 1) = Mid(LongVIN, 1, 10)
Cells(i, 2) = Mid(LongVIN, 11, 7)
Else:
Range("A" & i & ":A" & Row_Number).Delete 'ClearContents
Exit For
End If
Next i
You should see a significant boost in performance by storing the data in an array, operating on the array, and storing the data back into the spreadsheet.
Something like:
Dim data As Variant
Dim result As Variant
data = Range(Cells(2, 1), Cells(Row_Number, 1))
Redim result (1 To Row_Number, 1 To 7) As Variant
Now instead of reading from Cells(i, 1), you read from data(i, 1) and instead of writing to Cells(i, n) you write to result(i, n).
And at the end of your code:
Range(Cells(2, 1), Cells(Row_Number, 7)) = result
I tried putting the program into VBA, but I keep getting an error. This line was highlighted:
B(i, j) = C(i, j) + A(i + 1, j) * A(i, j + 1)
I am trying to multiply two of the same matrices and then add it to itself.
Suppose I wanted to multiply a 15 x 15 matrix, would I use the same codes except just change the dimensions and ranges?
Sub testing()
Dim A As Variant
Dim B(1 To 2, 1 To 2)
Dim C(1 To 2, 1 To 2)
A = Range("A1:B2").Value
i = 1
C(1, 1) = 0
Do Until i = 3
j = 1
Do Until j = 3
C(i, j) = C(i, j) + A(i, j) * A(j, i)
**B(i, j) = C(i, j) + A(i + 1, j) * A(i, j + 1)**
j = j + 1
Loop
i = i + 1
Loop
Range("E1:F2").Value = B
End Sub
Thanks!
Do...Loop is not the right tool for this job. Use For...Next instead. Also, to help make sure you don't overrun the array bounds and get a subscript out of range error, you can use LBound and UBound instead of hard-coding the index bounds. That way you don't have to change the code if you change the size of your input matrix.
This will get you part of the way. For simplicity I assumed A is a square matrix.
Dim i As Long, j As Long
Dim A As Variant
Dim B() As Variant
Dim C() As Variant
A = Range("A1:B2").Value
ReDim B(LBound(A, 1) To UBound(A, 1), LBound(A, 2) To UBound(A, 2))
ReDim C(LBound(A, 1) To UBound(A, 1), LBound(A, 2) To UBound(A, 2))
For i = LBound(A, 1) To UBound(A, 1)
For j = LBound(A, 2) To UBound(A, 2)
C(i, j) = C(i, j) + A(i, j) * A(j, i)
B(i, j) = C(i, j) + A(i + 1, j) * A(i, j + 1) ' still bad
Next j
Next i
Now you'll still get an error on that same line, due to the i+1 and j+1 indices. Those will have a value of 3 at some point, which is beyond your array bounds of 2. I can't help you fix that line, because I don't understand what you are trying to do with it.
Which brings me to my next point: if you think you're doing a matrix multiplication with this line
C(i, j) = C(i, j) + A(i, j) * A(j, i)
then you are wrong. The correct definition is:
and this is not what you have implemented.
A perhaps more convenient way to do it is to use the built-in MMult function:
C = WorksheetFunction.MMult(A, A)
I've played around with this for several hours and am no closer to a solution.
When I create an array the following way, it outputs to a range without any difficulties:
Dim Destination As Range
Set Destination = NewSheet.Range("A1")
ReDim OutArray(1 To 1, 1 To NumArrayCols) As Variant
OutArray(1, 1) = "hello"
Destination.Resize(UBound(OutArray, 1), UBound(OutArray, 2)).Value = OutArray
However, when I create an output array in the following manner, it simply pastes a big blank array onto my spreadsheet. The first section of the code is probably mostly irrelevant, but I want to include it in case I'm missing anything:
ReDim OutArray(1, 1 To NumArrayCols) As Variant
Set ThisAtt = Wells.CurrWell.FirstAttribute(Skip:=False)
k = 1
OutArray(1, k) = "UWI"
Do
ElevOffset = 0
Set ThisAtt = Wells.CurrWell.CurrAttribute
If InStr(LCase(ThisAtt.Name1), "elevation") Then
OutArray(1, k + 1) = ThisAtt.Name1
OutArray(1, k + 2) = ""
OutArray(1, k + 3) = ThisAtt.Name2
OutArray(1, k + 4) = ""
ElevOffset = ElevOffset + 2
Else
OutArray(1, k + 1) = ThisAtt.Name1
OutArray(1, k + 2) = ThisAtt.Name2
End If
OutArray(1, k + ElevOffset + 3) = "Recommend"
OutArray(1, k + ElevOffset + 4) = "Rec. Value"
OutArray(1, k + ElevOffset + 5) = "Comments"
k = k + ElevOffset + 2 + AdditionalColumns
Loop While Not (Wells.CurrWell.NextAttribute(EnableSkipping:=False) Is Nothing)
Dim Destination As Range
Set Destination = NewSheet.Range("A1")
Destination.Resize(UBound(OutArray, 1), UBound(OutArray, 2)).Value = OutArray
It's strange, because every element in OutArray, upon inspection, seems to be there. My hand-generated array works fine, but the automatically-generated array--which seems similar in almost every way--doesn't work. Anyone know why?
I suspect that it is just your REDIM statements. In your first example you have this:
ReDim OutArray(1 To 1, 1 To NumArrayCols) As Variant
but in the second example you do this:
ReDim OutArray(1, 1 To NumArrayCols) As Variant
Notice the difference? When you say ReDim A(1 To 1) both the upper and lower bounds are 1, but when you say just Redim(1) only the upper bound is 1, the lower bound is set to the default, which is zero (0). Thus the two arrays are not the same shape/size and therefore in your second case your array does not fit correctly into the Destination Range.