VB:Dim nx As Long, ny As Long Dim lowerx As Long, lowery As Long, upperx As Long, uppery As Long, i As Long Dim inputsarray() As Variant nx = inputs.Columns.Count - 1 ny = inputs.Rows.Count - 1 Redim inputsarray(nx + 1, ny + 1) inputsarray = inputs.Value If X < inputsarray(1, 0) Then lowerx = 1 upperx = 1 ElseIf X > inputsarray(nx, 0) Then lowerx = nx upperx = nx Else For i = 1 To nx If inputsarray(i, 0) >= X Then upperx = i lowerx = i - 1 Exit For End If Next End If If Y < inputsarray(0, 1) Then lowery = 1 uppery = 1 ElseIf Y > inputsarray(0, ny) Then lowery = ny uppery = ny Else For i = 1 To ny If inputsarray(0, i) >= Y Then uppery = i lowery = i - 1 Exit For End If Next End If Dim XL As Double, XU As Double, YL As Double, YU As Double Dim temp1 As Double, temp2 As Double XL = inputsarray(lowerx, 0) XU = inputsarray(upperx, 0) YL = inputsarray(0, lowery) YU = inputsarray(0, uppery) temp1 = (inputsarray(lowerx, lowery) * (XU - X) _ + inputsarray(upperx, lowery) * (X - XL)) / (XU - XL) temp2 = (inputsarray(lowerx, uppery) * (XU - X) _ + inputsarray(upperx, uppery) * (X - XL)) / (XU - XL) Linearinter22d = (temp1 * (YU - Y) + temp2 * (Y - YL)) / (YU - YL) End FunctionIf you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines
VB:Dim nx As Long, ny As Long Dim lowerx As Long, lowery As Long, upperx As Long, uppery As Long, i As Long Dim inputsarray() As Variant nx = inputs.Columns.Count - 1 ny = inputs.Rows.Count - 1 Redim inputsarray(nx + 1, ny + 1) inputsarray = inputs.Value If X < inputsarray(1, 0) Then lowerx = 1 upperx = 1 ElseIf X > inputsarray(nx, 0) Then lowerx = nx upperx = nx Else For i = 1 To nx If inputsarray(i, 0) >= X Then upperx = i lowerx = i - 1 Exit For End If Next End If If Y < inputsarray(0, 1) Then lowery = 1 uppery = 1 ElseIf Y > inputsarray(0, ny) Then lowery = ny uppery = ny Else For i = 1 To ny If inputsarray(0, i) >= Y Then uppery = i lowery = i - 1 Exit For End If Next End If Dim XL As Double, XU As Double, YL As Double, YU As Double Dim temp1 As Double, temp2 As Double XL = inputsarray(lowerx, 0) XU = inputsarray(upperx, 0) YL = inputsarray(0, lowery) YU = inputsarray(0, uppery) temp1 = (inputsarray(lowerx, lowery) * (XU - X) _ + inputsarray(upperx, lowery) * (X - XL)) / (XU - XL) temp2 = (inputsarray(lowerx, uppery) * (XU - X) _ + inputsarray(upperx, uppery) * (X - XL)) / (XU - XL) Linearinter22d = (temp1 * (YU - Y) + temp2 * (Y - YL)) / (YU - YL) End FunctionIf you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines
VB:--------------------------------------------------------------------------------------Range, _ dColVal As Double, dRowVal As Double) As Variant ' Returns the bilinear interpolation of Tbl using dColVal and dRowVal ' Tbl must be in ascending order left to right by the first row, ' and top to bottom by the first column Dim nRow As Long, nCol As Long ' dimensions of table Dim iRow1 As Long, iRow2 As Long ' bounding rows Dim iCol1 As Long, iCol2 As Long ' bounding columns Dim rf As Double, cf As Double ' row and column fractions, 0..1 Dim sL As Double, sR As Double ' column header values flanking dColVal Dim sT As Double, sB As Double ' row header values flanking dRowVal ' four corner table values flanking dColVal, dRowVal Dim sTL As Double, sTR As Double, sBR As Double, sBL As Double nRow = Tbl.Rows.Count nCol = Tbl.Columns.Count ' Tbl must be at least 3x3 including header row and column If nRow < 3 Or nCol < 3 Then BiLinterp = "Tbl must be at least 3x3" Exit Function '--------------------------------------------------------> End If ' value to be interpolated must lie within row and column headers If dColVal < Tbl(1, 2) Or dColVal > Tbl(1, nCol) _ Or dRowVal < Tbl(2, 1) Or dRowVal > Tbl(nRow, 1) Then BiLinterp = "Value not within table extents" Exit Function '--------------------------------------------------------> End If iCol1 = Application.Match(dColVal, Tbl(1, 2).Resize(, nCol - 1)) + 1 sL = Tbl(1, iCol1) If dColVal = sL Then iCol2 = iCol1 sR = sL Else iCol2 = iCol1 + 1 sR = Tbl(1, iCol2) cf = (dColVal - sL) / (sR - sL) ' column fraction End If iRow1 = Application.Match(dRowVal, Tbl(2, 1).Resize(nRow - 1), 1) + 1 sT = Tbl(iRow1, 1) If dRowVal = sT Then iRow2 = iRow1 sT = sB Else iRow2 = iRow1 + 1 sB = Tbl(iRow2, 1) rf = (dRowVal - sT) / (sB - sT) End If sTL = Tbl(iRow1, iCol1) sTR = Tbl(iRow1, iCol2) sBR = Tbl(iRow2, iCol2) sBL = Tbl(iRow2, iCol1) ' Compute the weighted sum of four locations in Tbl BiLinterp = sTL * (1 - rf) * (1 - cf) _ + sTR * (1 - rf) * cf _ + sBR * rf * cf _ + sBL * rf * (1 - cf) End FunctionIf you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines
VB:Dim rnge, mtrnge As Range Dim w, x, y, z, xx, yy, b As Single Dim scenario, a As Integer Dim J As Variant scenario = Worksheets("Input").Range("B1").Value pwr = pwr / 100# If (scenario = 1) Then Worksheets("ITC").Select 'Make table into a range for VLookUp Set rnge = Worksheets("ITC").Range("A3", [A3].End(xlDown).End(xlToRight)) Set mtrnge = Worksheets("ITC").Range("A3", [A3].End(xlDown)) 'If the given value does not match a table value exactly On Error Resume Next J = Application.WorksheetFunction.VLookup(efpd, rnge, 1, False) If Err.Number = 1004 Then w = Application.WorksheetFunction.VLookup(efpd, rnge, 1, True) x = Application.WorksheetFunction.VLookup(efpd, rnge, 2, True) y = Application.WorksheetFunction.VLookup(efpd, rnge, 3, True) 'If the given value is greater than, or equal to the largest table value If (w = Range("A3").End(xlDown).Value) Then itcinter = x + pwr * (y - x) Else 'If the given value requires a table interpolation a = Application.WorksheetFunction.Match(efpd, mtrnge, 1) z = Range("A" & a + 3).Value xx = Range("B" & a + 3).Value yy = Range("C" & a + 3).Value b = (z - w) itcinter = (x / b) * (z - efpd) * (1 - pwr) + _ (xx / b) * (efpd - w) * (1 - pwr) + _ (y / b) * (z - efpd) * (pwr - 0) + _ (yy / b) * (efpd - w) * (pwr - 0) End If 'If the given value does match a table value exactly ElseIf (Application.WorksheetFunction.VLookup(efpd, rnge, 1, False) >= 0) Then a = Application.WorksheetFunction.Match(efpd, mtrnge, 0) x = Range("B" & a + 2).Value y = Range("C" & a + 2).Value itcinter = x + pwr * (y - x) 'Only scenario left is an error Else itcinter = "error" End If End If End FunctionIf you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines
Function itcinter(efpd As Single, pwr As Single) As Variant Dim rnge, mtrnge As Range Dim w, x, y, z, xx, yy, b As Single Dim scenario, a As Integer Dim J As Variant scenario = Worksheets("Input").Range("B1").Value pwr = pwr / 100# If (scenario = 1) Then Worksheets("ITC").Select 'Make table into a range for VLookUp Set rnge = Worksheets("ITC").Range("A3", [A3].End(xlDown).End(xlToRight)) Set mtrnge = Worksheets("ITC").Range("A3", [A3].End(xlDown)) 'If the given value does not match a table value exactly On Error Resume Next J = Application.WorksheetFunction.VLookup(efpd, rnge, 1, False) If Err.Number = 1004 Then w = Application.WorksheetFunction.VLookup(efpd, rnge, 1, True) x = Application.WorksheetFunction.VLookup(efpd, rnge, 2, True) y = Application.WorksheetFunction.VLookup(efpd, rnge, 3, True) 'If the given value is greater than, or equal to the largest table value If (w = Range("A3").End(xlDown).Value) Then itcinter = x + pwr * (y - x) Else 'If the given value requires a table interpolation a = Application.WorksheetFunction.Match(efpd, mtrnge, 1) z = Range("A" & a + 3).Value xx = Range("B" & a + 3).Value yy = Range("C" & a + 3).Value b = (z - w) itcinter = (x / b) * (z - efpd) * (1 - pwr) + _ (xx / b) * (efpd - w) * (1 - pwr) + _ (y / b) * (z - efpd) * (pwr - 0) + _ (yy / b) * (efpd - w) * (pwr - 0) End If 'If the given value does match a table value exactly ElseIf (Application.WorksheetFunction.VLookup(efpd, rnge, 1, False) >= 0) Then a = Application.WorksheetFunction.Match(efpd, mtrnge, 0) x = Range("B" & a + 2).Value y = Range("C" & a + 2).Value itcinter = x + pwr * (y - x) 'Only scenario left is an error Else itcinter = "error" End If End If End Function
VB:Due to the high number of rows and columns to be used later, I would really like to use something that doesn't use Selection. Thank you.shiftCol = Sheets(1).Range("B3").Value * -1 'shift column = number of columns * -1 'used to get selection to point to the next D6 and so on Sheets(1).Range("C6").Select For i = 0 To transRow Step 1 For j = 0 To transCol Step 1 transMatrix(i, j) = Selection.Value Selection.Offset(0, 1).Select Next j Selection.Offset(1, shiftCol).Select Next iIf you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines