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
Related
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
I have a for loop that takes a user's input and one of the keys in my dictionary and passes them to a Damerau-Levenshtein function and based on the distance, overwrites the user's input with the dictionary key (The for loop is to cycle through each dictionary key). This works fine enough for strings larger than three characters, but if the string is three or fewer characters the algorithm returns with the wrong key. Here's the for loop:
1950 For j = 0 To dict.Count - 1
1960 distance = DamerauLevenshtein(SplitStr(i), dict.Keys(j))
1970 'MsgBox dict.Keys(j) & vbCrLf & distance ' used for debugging
1980 If distance < 4 Then
1990 If distance < leastDist Then
2000 leastDist = distance
2010 SplitStr(i) = dict.Keys(j)
2020 End If
2030 End If
2040 Next
2050 MsgBox "The distance is: " & leastDist & vbCrLf & "The entered text was " & tempStr & vbCrLf & "The replaced word is " & SplitStr(i)
SplitStr(i) holds the user's input, which comes from a split function. I arbitrarily picked 4 for a good distance
I stole the algorithm from a bytes.com forum post. Algorithm below:
Function DamerauLevenshtein(str1, str2, Optional intSize = 256)
Dim intTotalLen, arrDistance, intLen1, intLen2, i, j, arrStr1, arrStr2, arrDA, intMini
Dim intDB, intI1, intJ1, intD
str1 = UCase(str1)
str2 = UCase(str2)
intLen1 = Len(str1)
intLen2 = Len(str2)
intTotalLen = intLen1 + intLen2
ReDim arrStr1(intLen1)
ReDim arrStr2(intLen2)
ReDim arrDA(intSize)
ReDim arrDistance(intLen1 + 2, intLen2 + 2)
arrDistance(0, 0) = intTotalLen
For i = 0 To intSize - 1
arrDA(i) = 0
Next
For i = 0 To intLen1
arrDistance(i + 1, 1) = i
arrDistance(i + 1, 0) = intTotalLen
Next
For i = 1 To intLen1
arrStr1(i - 1) = Asc(Mid(str1, i, 1))
Next
For j = 0 To intLen2
arrDistance(1, j + 1) = j
arrDistance(0, j + 1) = intTotalLen
Next
For j = 1 To intLen2
arrStr2(j - 1) = Asc(Mid(str2, j, 1))
Next
For i = 1 To intLen1
intDB = 0
For j = 1 To intLen2
intI1 = arrDA(arrStr2(j - 1))
intJ1 = intDB
If arrStr1(i - 1) = arrStr2(j - 1) Then
intD = 0
Else
intD = 1
End If
If intD = 0 Then intDB = j
intMini = arrDistance(i, j) + intD
If intMini > arrDistance(i + 1, j) + 1 Then intMini = arrDistance(i + 1, j) + 1
If intMini > arrDistance(i, j + 1) + 1 Then intMini = arrDistance(i, j + 1) + 1
If intMini > arrDistance(intI1, intJ1) + i - intI1 + j - intJ1 - 1 Then intMini = arrDistance(intI1, intJ1) + i - intI1 + j - intJ1 - 1
arrDistance(i + 1, j + 1) = intMini
Next
arrDA(arrStr1(i - 1)) = i
Next
DamerauLevenshtein = arrDistance(intLen1 + 1, intLen2 + 1)
End Function
If I type in "Cire" the algorithm correctly returns "CORE".
"Raman" returns "REMAN"
"Cosnigned" returns "CONSIGNED
However, "Now" should return "New" but returns "OCM".
"New" also returns "OCM" (so distance should be 0, but is 2.)
"FP" should be "FP" but returns "OCM", distance is 2
"DPF" Should be "DPF" but returns "OCM", distance is 2
I just learned about the algorithm, so I'm sure I'm missing something important, but I just can't see it. Thoughts?
I figured it out. After much searching I found a post saying that an edit distance is commonly 2. (They didn't specify any merits on why 2 is common)
I switched my if statement to 2 from 4 and now all of the problem terms are being corrected as they should be.
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 am manually transposing a large array from a recordset (.transpose did not work) but the first column is missing. Can anyone tell me where I went wrong
Dim FinalArr As Variant
ReDim FinalArr(1 To UBound(ArrRs1, 2), 1 To UBound(ArrRs1, 1))
For i = 1 To UBound(ArrRs1, 2)
For j = 1 To UBound(ArrRs1, 1)
FinalArr(i, j) = ArrRs1(j, i)
Next
Next
The array had a lower bound of 0.
Dim PasteArray As Variant
ReDim PasteArray(1 To UBound(ArrRs1, 2), 0 To UBound(ArrRs1, 1))
For i = 1 To UBound(ArrRs1, 2)
For j = 0 To UBound(ArrRs1, 1)
PasteArray(i, j) = ArrRs1(j, i)
Next
Next
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)