Related
I'm stuck for hours solving my case. Code included below, I'll explain my case first for better understanding and to be easier to follow.
I have created a two dimensional array that has multiple compounds and corresponding heating values for them at two temperatures- it is contained in code and the user does not have a view of it.
The user types in the compounds and percentages of the mixture into the cells, and I want the selected cells that make up the array of multiple rows and two columns to be added to the two-dimensional array and then used in the function created to calculate a certain value (which is shown in the attached screenshot).
Ultimately, I want the program to search the user's entered and selected table to match the union name with the array, which is "hidden "in the code to properly perform the algebraic operation.
Code:
Function LoopThroughArray(T, x)
Dim arr() As Variant
ReDim arr(2, 4)
arr(0, 0) = "CH4"
arr(0, 1) = 35.818
arr(0, 2) = 35.808
arr(1, 0) = "C2H6"
arr(1, 1) = 63.76
arr(1, 2) = 63.74
arr(2, 0) = "C3H8"
arr(2, 1) = 91.18
arr(2, 2) = 91.15
Dim arrUser() As Variant
ReDim arrUser(2, 4)
arrUser(0, 0) = "CH4"
arrUser(0, 1) = 0.7
arrUser(1, 0) = "C2H6"
arrUser(1, 1) = 0.3
'declare variables for the loop
Dim i As Long, j As Long
'loop for the first dimension
For i = LBound(arr, 1) To UBound(arr, 1)
'loop for the second dimension
For j = LBound(arr, 2) To UBound(arr, 2)
If T = 0 And arr(i, j) = "CH4" And arrUser(i, j) = "CH4" Then
LoopThroughArray = arr(i, j + 1) * x 'the X is concentration of CH4 selected by user
Else
If T = 25 And arr(i, j) = "CH4" And arrUser(i, j) = "CH4" Then
LoopThroughArray = arr(i, j + 2) * x 'the X is concentration of CH4 selected by user
End If
End If
Next j
Next i
End Function
Screenshot from Excel:
I am also attaching a screenshot showing the values of the table that is embedded in the code, and how the function would ultimately work.
Problem:
Currently, my code that I have written only works when the function is for a CH4 compound and the user manually select cell containing value of concentration (x in my code).
How should I modify the code so that the function/loop will search the table entered by the user, match the compound names from it with those in the built-in table in the code and calculate a value in the form: concentration (user defined, currently the x value in my code) * LHV for specific compound in desired temperatures (0 or 25 deg).
1. Edit:
What would I need to change to make the function independent of whether compounds/concentrations are entered not in columns but in rows?
2. Edit:
I changed the code a bit, where in the built-in array for compounds, the values are calculated by a polynomial that takes the temperature "T" set in the function.
a. I have created "if" conditions that inform about incorrectly entered data. I used WorksheetFunction.[...] for this (I wonder if using this option is the correct approach to the problem). When I use the function even in another worksheet, one message activates the messages from the other cells when they meet the conditions. Even when I launch the excel file the message pops up.
Question 1: how should I change the code below so that the message pops up only once, when the formula is entered (when the assumed condition is met)?
b. Question 2: how to create conditions that:
-when the temperature entered in the function is below 25 degrees for the selected compounds, a message will pop up to inform you of this (this applies to all compounds, including air),
-when the temperature entered in the function will be above 2200 degrees for the selected compounds where air will be, a message will appear informing that the temperature for air is out of range,
-if the temperature entered in the function is above 3000 degrees for the selected compounds, a message appears, informing that the temperature is out of range.
Example:
Code:
Public Function Cp_mix_t(T, compounds As Range, concentrations As Range) As Double
Dim arr() As Variant
Dim i As Long, j As Long, k As Long
Dim curRow As Range
Dim ret As Double, x As Double
TN=273
'Array of compounds and polynomials defining Cp
ReDim arr(29, 2)
arr(0, 0) = "CH4"
arr(0, 1) = -1.9E-14 * (T + TN) ^ 5 + 2.1E-10 * (T + TN) ^ 4 - 7.1E-07 * (T + TN) ^ 3 + 7.8E-04 * (T + TN) ^ 2 + 1.4 * (T + TN) ^ 1 + 1709.8
arr(20, 0) = "N2"
arr(20, 1) = -3.5E-15 * (T + TN) ^ 5 + 3.9E-11 * (T + TN) ^ 4 - 1.61E-07 * (T + TN) ^ 3 + 2.87E-04 * (T + TN) ^ 2 - 0.17 * (T + TN) ^ 1 + 1054.5
arr(28, 0) = "AIR"
arr(28, 1) = -9.8E-15 * (T + TN) ^ 5 + 8.4E-11 * (T + TN) ^ 4 - 2.7E-07 * (T + TN) ^ 3 + 4.1E-04 * (T + TN) ^ 2 - 0.16 * (T + TN) ^ 1 + 1027.9
concentrationHasRows = True
If concentrations.Columns.Count > 1 Then
concentrationHasRows = False
End If
For Each Cell In concentrations 'It checks if negative values of percentages in selected cells have been entered. If so, a warning appears and the program does not count Cp - it gives a value of 0
If Cell.Value < 0 Then
MsgBox ("A negative value was entered!")
Cp_mix_t = 0
Exit Function
End If
Next Cell
If compounds.Count <> concentrations.Count Then 'It checks if the number of entered compounds matches the number of entered percentages. If not, a message appears and the program does not count Cp - it gives a value of 0
MsgBox ("Wrong selection! Check the selected range of compounds/percentages.")
Cp_mix_t = 0
Exit Function
ElseIf WorksheetFunction.Sum(concentrations) > 1 Then 'It checks if the sum of percentages >100%. If so, a warning appears and the program does not count Cp - it gives a value of 0
MsgBox ("Sum of percentages greater than 100%!")
Cp_mix_t = 0
Exit Function
ElseIf WorksheetFunction.Sum(concentrations) > 0 And WorksheetFunction.Sum(concentrations) < 1 Then 'It checks if the sum of the percentages =100%. If yes, then only the message
MsgBox ("The sum of the percentages is not equal to 100%!")
End If
' Loop through user input rows:
k = 1
For Each m In compounds
arraycompound = Trim(UCase(m.Value2))
For i = 0 To UBound(arr, 1)
If arr(i, 0) = arraycompound Then
' x retrieves user's input of concentration:
If concentrationHasRows Then
x = concentrations.Cells(k, 1).Value2
Else
x = concentrations.Cells(1, k).Value2
End If
If T < 25 Then
MsgBox ("Temperature below 25 deg")
ElseIf T > 2200 And arr(i, 0) = "AIR" Then
MsgBox ("Temperature for air above 2200 deg ")
' ElseIf T > 3000 And arr(i, 0) = Not "AIR" Then
' MsgBox ("Temperature for compounds above 3000 deg")
End If
ret = ret + arr(i, j + 1) * x
Exit For
End If
Next
k = k + 1
Next
Cp_mix_t = ret
End Function
(Re-edited)
I have found this possible solution. The code in Data module would be:
' call the function like in =LHV(25;A9:B10;E5:E6)
Function LHV(T, compounds As Range, concentrations As Range) As Double
Dim rng1 As Range, rng2 As Range
If ThisWorkbook.done = False Then
ThisWorkbook.numMsg = 0
ThisWorkbook.done = True
For Each cell In compounds.Application.ActiveSheet.UsedRange
If cell.HasFormula Then
' change down here "LHV(" by your formula's name:
If InStr(Replace(UCase(cell.Formula), " ", ""), "LHV(") Then
v = Split(cell.Formula, ",") ' code arrives here?
pos = InStr(v(0), "(")
v(0) = Mid(v(0), pos + 1)
Set rng1 = Range(v(1))
v(2) = Replace(v(2), ")", "")
Set rng2 = Range(v(2))
cellLHV v(0), rng1, rng2
End If
End If
Next
End If
If ThisWorkbook.numMsg And 1 Then
MsgBox ("Temperature below 25 deg")
End If
If ThisWorkbook.numMsg And 2 Then
MsgBox ("Temperature for air above 2200 deg ")
End If
If ThisWorkbook.numMsg And 4 Then
' MsgBox ("Temperature for compounds above 3000 deg")
End If
If ThisWorkbook.numMsg And 8 Then
' MsgBox ("Some other message")
End If
ThisWorkbook.numMsg = 0
LHV = cellLHV(T, compounds, concentrations)
ThisWorkbook.done = False
End Function
Function cellLHV(T, compounds As Range, concentrations As Range) As Double
Dim arr() As Variant
Dim strFind As String
Dim i As Long, j As Long, k As Long
Dim curRow As Range
Dim ret As Double, x As Double
ReDim arr(2, 4)
arr(0, 0) = "CH4"
arr(0, 1) = 35.818
arr(0, 2) = 35.808
arr(1, 0) = "C2H6"
arr(1, 1) = 63.76
arr(1, 2) = 63.74
arr(2, 0) = "C3H8"
arr(2, 1) = 91.18
arr(2, 2) = 91.15
concentrationHasRows = True
If concentrations.Columns.Count > 1 Then
concentrationHasRows = False
End If
' Loop through user input rows:
k = 1
For Each m In compounds
arraycompound = Trim(UCase(m.Value2))
For i = 0 To UBound(arr, 1)
If arr(i, 0) = arraycompound Then
' x retrieves user's input of concentration:
If concentrationHasRows Then
x = concentrations.Cells(k, 1).Value2
Else
x = concentrations.Cells(1, k).Value2
End If
If T < 25 Then
ThisWorkbook.numMsg = ThisWorkbook.numMsg Or 1
ElseIf T > 2200 And arr(i, 0) = "AIR" Then
ThisWorkbook.numMsg = ThisWorkbook.numMsg Or 2
'ElseIf T > 3000 And arr(i, 0) = Not "AIR" Then
'ThisWorkbook.numMsg = ThisWorkbook.numMsg Or 4
' ElseIf ..... then
'ThisWorkbook.numMsg = ThisWorkbook.numMsg Or 8
End If
ret = ret + arr(i, j + 1) * x
Exit For
End If
Next
k = k + 1
Next
cellLHV = ret
End Function
...and the code from Data's ThisWorkbook:
Public numMsg As Long
Public done As Boolean
Private Sub Workbook_SheetCalculate(ByVal Sh As Object)
ThisWorkbook.done = False
End Sub
Also converting arr() into a global Public variable speed can be improved.
If temperature T is going to be a cell range then change the function into:
Public Function Cp_mix_t(T, compounds As Range, concentrations As Range) As Double
Dim rng1 As Range, rng2 As Range
Dim rng0 As Range
If ThisWorkbook.done = False Then
ThisWorkbook.numMsg = 0
ThisWorkbook.done = True
For Each cell In compounds.Application.ActiveSheet.UsedRange
If cell.HasFormula Then
If InStr(Replace(cell.Formula, " ", ""), "Cp_mix_t(") Then
v = Split(cell.Formula, ",")
pos = InStr(v(0), "(")
v(0) = Mid(v(0), pos + 1)
Set rng0 = Range(v(0))
Set rng1 = Range(v(1))
v(2) = Replace(v(2), ")", "")
Set rng2 = Range(v(2))
' code arrives here ?
cellCp_mix_t rng0, rng1, rng2
End If
End If
Next
End If
If ThisWorkbook.numMsg And 1 Then
MsgBox ("Temperature below 25 deg")
End If
If ThisWorkbook.numMsg And 2 Then
MsgBox ("Temperature for air above 2200 deg ")
End If
If ThisWorkbook.numMsg And 4 Then
' MsgBox ("Temperature for compounds above 3000 deg")
End If
If ThisWorkbook.numMsg And 8 Then
' MsgBox ("Some other message")
End If
ThisWorkbook.numMsg = 0
Cp_mix_t = cellCp_mix_t(T, compounds, concentrations)
ThisWorkbook.done = False
End Function
I'm trying to find an index of the minimum value from sum(3) array. And it should be assigned to a variable min
min = index of minimum value
Should I sort the array first or is there any direct way of doing it?
Here is my code:
`Sub Min_index()
Dim Pt_array(3) As Single
Pt_array(0) = 0
Pt_array(1) = 12.3
Pt_array(2) = 16.06
Pt_array(3) = 20.11
Dim Ad_E_array(3) As Single
Dim Lo_E_array(3) As Single
Dim Bs_temp As Single
Dim i As Integer
i = 0
Do While i < 4
Bs_temp = BS
Ad_E_array(i) = Ad_E 'defined in previous Sub
Lo_E_array(i) = Lo_E 'defined in previous Sub
If Bs_temp + Pt_array(i) - Qth < BS_Maximum_limit Then
Bs_temp = Bs_temp + Pt_array(i) - Qth
Ad_E_array(i) = Ad_E_array(i) + 0
Lo_E_array(i) = Lo_E_array(i) + 0
Call function_decide(int_forecast_hour - 1, Bs_temp, Qth + 1, Lo_E_array(i), Ad_E_array(i))
Else
Lo_E_array(i) = Pt_array(i) - Qth - (BS_Maximum_limit - Bs_temp)
Bs_temp = BS_Maximum_limit
Call function_decide(int_forecast_hour - 1, Bs_temp, Qth + 1, Lo_E_array(i), Ad_E_array(i))
End If
i = i + 1
Loop
Dim sum(3) As Single
Dim min As Single
i = 0
Do While i < 4
sum(i) = Abs(Lo_E_array(i)) + Abs(Ad_E_array(i))
i = i + 1
Loop
End Sub`
You can receive the 1-based index position of the element containing the minimum value with the an Excel Application object's use of the worksheet's MIN function and MATCH function.
Sub wqewuiew()
Dim Pt_array(3) As Single, p As Long
Pt_array(0) = 1000
Pt_array(1) = 12.3
Pt_array(2) = 16.06
Pt_array(3) = 20.11
p = Application.Match(Application.Min(Pt_array), Pt_array, 0)
Debug.Print p '<~~ 'p' is 2 (I changed the value of the first array element)
End Sub
I am trying to have my code prompt the user to select a range of data of 3 width and variable length. There will only be 30 values those with some rows being blank. I want to have these 30 values populate into 30 text boxes in a userform of mine (this is so values don't have to be manually entered). I looked around and figured my route should be Application.Inputbox and then pass it into an array were the blank rows can be weeded out with for loops. I don't know how to pass the user selected table into a 2D array though.
Sub selectRange()
Dim r(1 To 14, 1 To 3) As Variant, ran As Range, calB(1 To 30) As Long, i As Integer, j As Integer, k As Integer, l As Integer
dozerCal.Hide
Set r = Application.InputBox("Select the Cal B table.", Type:=8)
For j = 1 To 14
For i = 1 To 3
If Abs(r(j, i)) > 0 Then
calB(l) = r(j, i)
l = l + 1
End If
Next
Next
lx = calB(1)
ly = calB(2)
lz = calB(3)
rx = calB(4)
ry = calB(5)
rz = calB(6)
ix = calB(7)
iy = calB(8)
iz = calB(9)
sx = calB(10)
sy = calB(11)
sz = calB(12)
p1x = calB(13)
p1y = calB(14)
p1z = calB(15)
p2x = calB(16)
p2y = calB(17)
p2z = calB(18)
lfx = calB(19)
lfy = calB(20)
lfz = calB(21)
lrx = calB(22)
lry = calB(23)
lrz = calB(24)
rfx = calB(25)
rfy = calB(26)
rfz = calB(27)
rrx = calB(28)
rry = calB(29)
rrz = calB(30)
ActiveWorkbook.Close
dozercall.Show
End Sub
Thanks in advance for everyone's help.
Edit: I missed that you were using the input box wrong, however I will leave this answer as it presents a way to collapse a variable range of user input from a multidimensional array into a single dimension array.
This should get you started. Basically it will read the user's input, dynamically create a one-dimensional array of the correct size (rows * columns), and read all the values in the range the user selects to this one dimensional array. It will then loop through the one dimensional array and print the values back out to the window.
I think this is what you're looking for, but if you need further clarification I can add some. I added comments so you can see what each section is doing.
Option Explicit
Private Sub TestArrays()
Dim calBTemp() As Variant, calB() As Variant
Dim i As Long, j As Long, x As Long
Dim rngInput As Range
Set rngInput = Application.InputBox("Select the Cal B table.", "Select Range", Type:=8)
'Read the user input, check for empty input
'If empty input, exit the subroutine
If Not rngInput Is Nothing Then
calBTemp = rngInput
Else
Exit Sub
End If
'Create the one-dimensional array dynamically based on user selection
ReDim calB((UBound(calBTemp, 1) - LBound(calBTemp, 1) + 1) * (UBound(calBTemp, 2) - LBound(calBTemp, 2) + 1))
'Loop through our multidimensional array
For i = LBound(calBTemp, 1) To UBound(calBTemp, 1)
For j = LBound(calBTemp, 2) To UBound(calBTemp, 2)
'Assign the value to our one dimensional array
calB(x) = calBTemp(i, j)
x = x + 1
Next j
Next i
'Loop through our one dimensional array
For i = LBound(calB) To UBound(calB)
Debug.Print calB(i)
Next i
End Sub
So I just wasn't using the Application.Inputbox right. If you return it as a range it will configure to the proper sized 2D array it seams and you can call/manipulate data from there. Here is a working sub.
Sub selectRange()
Dim ran As Range, calB(1 To 30) As Double, i As Integer, j As Integer, k As Integer, l As Integer
dozerCal.Hide
Set ran = Application.InputBox("Select the Cal B table.", Type:=8)
l = 1
For j = 1 To 14
For i = 1 To 3
If Abs(ran(j, i)) > 0 Then
calB(l) = ran(j, i)
l = l + 1
End If
Next
Next
lx = calB(1)
ly = calB(2)
lz = calB(3)
rx = calB(4)
ry = calB(5)
rz = calB(6)
ix = calB(7)
iy = calB(8)
iz = calB(9)
sx = calB(10)
sy = calB(11)
sz = calB(12)
p1x = calB(13)
p1y = calB(14)
p1z = calB(15)
p2x = calB(16)
p2y = calB(17)
p2z = calB(18)
lfx = calB(19)
lfy = calB(20)
lfz = calB(21)
lrx = calB(22)
lry = calB(23)
lrz = calB(24)
rfx = calB(25)
rfy = calB(26)
rfz = calB(27)
rrx = calB(28)
rry = calB(29)
rrz = calB(30)
ActiveWorkbook.Close
dozerCal.Show
End Sub
This code will do the trick (and forces the user to select 3 columns and 14 rows):
Sub selectRange()
Dim selectedRange As Range
Dim errorMessage As String
errorMessage = vbNullString
Dim ran As Range, calB(1 To 30) As Long, i As Integer, j As Integer, k As Integer, l As Integer
Do
'doesn't handle cancel event
Set selectedRange = Application.InputBox("Select the Cal B table.", _
Type:=8, Title:="Please select 14 rows and 3 columns" & errorMessage)
errorMessage = "; previous selection was invalid"
Loop While selectedRange.Columns.Count <> 3 Or selectedRange.Rows.Count <> 14
For j = 1 To 14
For i = 1 To 3
If Abs(selectedRange.Cells(j, i)) > 0 Then
calB(l) = selectedRange.Cells(j, i)
l = l + 1
End If
Next
Next
...rest of your code
*******Background*******
For reasons not up for debate I am using Excel 2010 and VBA to program a scientific model that involves a user inputting data to a worksheet from an online data bank for each species involved. The number of species may change from simulation to simulation. As the program iterates, it calls many functions multiple times (some in the tens of thousands of times). The execution speed of the program is becoming too long so I would like to try and speed it up. In my mind two easy things to increase the execution speed are to decrease the number of worksheet calls and to minimize the number of variants I have to use.
Also of note that several of the functions share the same constants.
I've looked elsewhere on stackexchange and other sites but I still haven't found what I'm looking for ♪. Maybe I just don't have the right search terms.
The question(s)
Because the number of species is not constant and because I would like to make a few arrays of constants available to multiple functions is there away that I can define say a global variable that is an double (or single) precision array that is dimensionalized when a sub is run, reads the constants from the excel sheet once, and then is destroyed when my "main" sub is finished executing?
I could create the array(s) in the main sub and pass it as an argument but several of my functions call other functions as arguments already and several of my lines are extremely long and hard to read. By making these constants arguments to pass to the functions only increases the length of these lines.
Second question if I can't create a global array variable is there away to call the worksheet once (like I have done) but to make the variable a double instead of a variant? I couldn't get the following to work because of the type mismatch error.
Dim C() As Double
redim c(1 to 7, 1 to n)
C = Application.Transpose(Worksheets("Viscosity2").Range("J10:p19"))
Function example: I have a function that I am running in VBA. This function is called tens of thousands of times in the course of my program. I would like to make the C(1 to 7, 1 to n) array and the mw(1 to n) array double precision arrays that call the worksheet once and then are available to multiple functions.
Below is that example function:
Function mumx(y, T)
'this function calculates the mixture viscosity using the Chapman Enskog Wilke method
'using the mol fraction vector, y, and the temperature T
n = UBound(y, 1) - LBound(y, 1) + 1 'number of species
'***********Get Equation Parameters from Worksheet**************
Dim C() As Variant
C = Application.Transpose(Worksheets("Viscosity2").Range("J10:p19"))
Dim mw As Variant
mw = Application.Transpose(Worksheets("Viscosity2").Range("g10:g19"))
'***************************************************************
Dim mu() As Double
ReDim mu(1 To n)
For i = 1 To n Step 1
mu(i) = (C(1, i) * (T ^ C(2, i))) / (1 + C(3, i) / T + (C(4, i) / (T ^ 2)))
Next i
Dim phi() As Double
ReDim phi(1 To n, 1 To n)
For i = 1 To n
For j = 1 To n
phi(i, j) = 1 / 8 ^ 0.5 * (1 + mw(i) / mw(j)) ^ -0.5 * (1 + (mu(i) / mu(j)) ^ 0.5 * (mw(j) / mw(i)) ^ 0.25) ^ 2
test = 1
Next j
Next i
Dim denom As Double
Dim mumix As Double
denom = 0
mumix = 0
For i = 1 To n
For j = 1 To n
denom = denom + y(j) * phi(i, j)
Next j
mumix = mumix + y(i) * mu(i) / denom
denom = 0
Next i
mumx = mumix
'where the units on mumx are in units of cP (which are 1 gm/(m*s))
End Function
'************Example constants are as follows********
'PS should someone stumble on this looking for say viscosity data
'the following constants just example constants
'
'
'C(1, 1) = 0.00018
'C(1, 2) = 0.000017
'C(1, 3) = 0.001113
'C(1, 4) = 0.00215
'C(1, 5) = 0.0005255
'C(1, 6) = 0.0011
'C(1, 7) = 0.0006559
'C(1, 8) = 0.00005
'C(1, 9) = 0.00026
'C(1, 10) = 0.002079
'
'C(2, 1) = 0.69
'C(2, 2) = 1.115
'C(2, 3) = 0.534
'C(2, 4) = 0.46
'C(2, 5) = 0.59
'C(2, 6) = 0.563
'C(2, 7) = 0.608
'C(2, 8) = 0.90
'C(2, 9) = 0.68
'C(2, 10) = 0.4163
'
'C(3, 1) = -0.59
'C(3, 2) = 0
'C(3, 3) = 94.7
'C(3, 4) = 290.
'C(3, 5) = 106.
'C(3, 6) = 96.3
'C(3, 7) = 54.7
'C(3, 8) = 0
'C(3, 9) = 98.9
'C(3, 10) = 353.
'
'C(4, 1) = 140.
'C(4, 2) = 0
'C(4, 3) = 0
'C(4, 4) = 0
'C(4, 5) = 0
'C(4, 6) = 0
'C(4, 7) = 0
'C(4, 8) = 0
'C(4, 9) = 0
'C(4, 10) = 0
'
'
'C(5, 1) = 0
'C(5, 2) = 0
'C(5, 3) = 0
'C(5, 4) = 0
'C(5, 5) = 0
'C(5, 6) = 0
'C(5, 7) = 0
'C(5, 8) = 0
'C(5, 9) = 0
'C(5, 10) = 0
'
'C(6, 1) = 300
'C(6, 2) = 300
'C(6, 3) = 300
'C(6, 4) = 300
'C(6, 5) = 300
'C(6, 6) = 300
'C(6, 7) = 300
'C(6, 8) = 300
'C(6, 9) = 300
'C(6, 10) = 300
'
'C(7, 1) = 1000
'C(7, 2) = 1000
'C(7, 3) = 1000
'C(7, 4) = 1000
'C(7, 5) = 1000
'C(7, 6) = 1000
'C(7, 7) = 1000
'C(7, 8) = 1000
'C(7, 9) = 1000
'C(7, 10) = 1000
'
'
'
'mw(1) = 2.0158
'mw(2) = 18.0148
'mw(3) = 28.01
'mw(4) = 44.009
'mw(5) = 16.0426
'mw(6) = 31.998
'mw(7) = 28.014
'mw(8) = 44.0962
'mw(9) = 30.0694
'mw(10) = 28.0536
'
''******************************
Yes, you can and should* use an array to store the constants entered by the user and yes, you can make it global so that it doesn't have to be passed to the other functions.
Here's an example; note that the data is read into a Variant first, then transferred to the array--this was your missing step that lead to the Type Mismatch error. While this may look like too much code for the effort, transferring the data into the Double array will be many times faster than reading the cells one-by-one.
Public C() As Double
Public Sub PopulateArrayC(n As Integer)
ReDim C(1 To 7, 1 To n)
Dim v As Variant
v = Application.Transpose(Worksheets("Viscosity2").Range("J10:P" & n + 10 - 1))
Dim i As Integer, j As Integer
For i = 1 To 7
For j = 1 To n
C(i, j) = v(i, j)
Next j
Next i
End Sub
*Reading from and writing to cells is very time consuming. Whenever possible, limit the number of reads and writes by*
storing frequently used values in variables, and
reading/writing whole ranges at a time.
In the following code I built 2 arrays:
One contains a "degree data" (so basically an Integer array increasing one by one) representing a portion of degrees in a circumference.
The second one a "power data" (a Double, whose values keep more or less cubic increasing until a maximum corresponding to a 0 in the first array. Then they will decrease almost as they increased). This array goes for example from values that are more or less -4.0 to more or less -4.0.
I thought I could "simplify" the second one to a parabola (looks very much like one) and use its coefficients (calculated via LinEst) A, B, C and D to interpolate data between points.
What I do need is to find with a 0.1 degrees precision the 2 numbers which are nearest to -3.0 and then find their "distance" in degrees.
Problem is: I can't manage to do it. There is something I'm missing and the coefficients seems not to represent my set of data.
Dim i As Integer, j As Integer
Dim MaxVal As Double, MaxAngle As Integer, CyclicAngle As Double
Dim XValues() As Double, YValues() As Double, Coeff As Variant
Dim LeftAngle As Double, RightAngle As Double, LeftAngleValue As Double, RightAngleValue As Double
' Searches for the maximum value and its angle
MaxVal = -80
ReDim YValues(359 * 3 + 2)
For i = 3 To 362 ' This will fill arrays from a worksheet (defined as Public in
' another subroutine) in which the data starts from row 3. I need the data stored in
' the 2nd column)
For j = 0 To 2 ' since the array represents a circumference, i make it "cyclic"
YValues((i - 3) + (360 * j)) = TargetSheet.Cells(i, 2)
Next j
If TargetSheet.Cells(i, 2) > MaxVal Then
MaxVal = TargetSheet.Cells(i, 2)
MaxAngle = i - 3
End If
Next
' The following searches the "middle" maximum
i = 0
j = 0
Do Until j = 2
If YValues(i) = MaxVal Then
j = j + 1
CyclicAngle = i
End If
i = i + 1
Loop
' Searches in the middle for the <-3 (we name it "-4") values
i = CyclicAngle
Do Until YValues(i) < -3
i = i + 1
Loop
RightAngle = i + 1
i = CyclicAngle
Do Until YValues(i) < -3
i = i - 1
Loop
LeftAngle = i - 1
' Copying only the "-4" to "-4"
ReDim XValues(RightAngle - LeftAngle)
For i = 0 To RightAngle - LeftAngle
XValues(i) = YValues(LeftAngle + i)
Next i
' Now correctly store the data in a new ordered array
ReDim YValues(UBound(XValues))
For i = 0 To UBound(XValues)
YValues(i) = XValues(i)
XValues(i) = LeftAngle - 360 + i
Next i
Here is the critic point:
' Gets the coefficients of a 3rd degree curve representing the Y-Array
Coeff = Application.LinEst(Application.Transpose(YValues), Application.Power(Application.Transpose(XValues), Array(1, 2, 3)), True, False)
' Sets the arrays to have a point every 0.1°
LeftAngle = LeftAngle * 10
RightAngle = RightAngle * 10
MaxAngle = MaxAngle * 10
ReDim XValues(RightAngle - LeftAngle)
ReDim YValues(RightAngle - LeftAngle)
For i = LeftAngle To RightAngle
XValues(i - LeftAngle) = i / 10
YValues(i - LeftAngle) = Coeff(1) * (i / 10) ^ 3 + Coeff(2) * (i / 10) ^ 2 + Coeff(3) * (i / 10) + Coeff(4)
Next
Now if I look at the YValues array, the numbers stored inside don't look absolutely how they should be.
How do I interpolate to find those -3s then?
The error was in this piece of code: I didn't think I could not "rotate" the XValues array
' Now correctly store the data in a new ordered array
ReDim YValues(UBound(XValues))
For i = 0 To UBound(XValues)
YValues(i) = XValues(i)
XValues(i) = LeftAngle + i ' Was LeftAngle - 360 + i
Next i
I should now be able to find my -3.0 with a simple loop iteration.
There are of course a few obstacles but since I have the LeftAngle and RightAngle references I should be able to solve all.
Full Solution
Please see my Question and correct it with the code above. From the "critic point" it goes:
' Gets the coefficients of a 3rd degree curve representing the Y-Array
' and build an interpolation array whose points are every 0.1°
Coeff = Application.LinEst(Application.Transpose(YValues), Application.Power(Application.Transpose(XValues), Array(1, 2, 3)), True, False)
'TargetSheet.Range("E1:H1") = Coeff
' Sets the arrays to be every 0.1°
LeftAngle = LeftAngle * 10
RightAngle = RightAngle * 10
j = CInt(LeftAngle)
k = CInt(RightAngle)
ReDim XValues(k - j)
ReDim YValues(k - j)
For i = j To k
XValues(i - LeftAngle) = i / 10
YValues(i - LeftAngle) = Coeff(1) * (i / 10) ^ 3 + Coeff(2) * (i / 10) ^ 2 + Coeff(3) * (i / 10) + Coeff(4)
Next
' Now searches for the -3dB angles with a better resolution
RightAngleValue = 10
LeftAngleValue = 10
CyclicAngle = CyclicAngle * 10
i = 0
Do Until XValues(i) > CyclicAngle / 10
If Abs(YValues(i) +3) < LeftAngleValue Then
LeftAngleValue = Abs(YValues(i) + 3)
LeftAngle = i * 0.1
End If
i = i + 1
Loop
Do Until i > UBound(XValues)
If Abs(YValues(i) +3) < RightAngleValue Then
RightAngleValue = Abs(YValues(i) + 3)
RightAngle = i * 0.1
End If
i = i + 1
Loop
myFunction = RightAngle - LeftAngle