If Abs(xi - x1) < Abs(0.00001 * xi) And Abs(yi - y1) < Abs(0.00001 * yi) Then GoTo 10
If Abs(xi - x2) < Abs(0.00001 * xi) And Abs(yi - y2) < Abs(0.00001 * yi) Then GoTo 10
If Abs(x1 - x2) < (0.0000001 * x1) Then If (yi - y1) * (yi - y2) < 0 Then GoTo 10 Else GoTo 20
If (xi - x1) * (xi - x2) < 0 Then GoTo 10
GoTo 20
10
If Abs(xi - x3) < Abs(0.00001 * xi) And Abs(yi - y3) < Abs(0.00001 * yi) Then GoTo 30
If Abs(xi - x4) < Abs(0.00001 * xi) And Abs(yi - y4) < Abs(0.00001 * yi) Then GoTo 30
If Abs(x3 - x4) < Abs(0.000001 * yi) Then If (yi - y3) * (yi - y4) < 0 Then GoTo 30 Else GoTo 20
If (xi - x3) * (xi - x4) < 0 Then GoTo 30
GoTo 20
30 F = 1
20
If Abs(xi - x1) < Abs(0.00001 * xi) And Abs(yi - y1) < Abs(0.00001 * yi) Or _
Abs(xi - x2) < Abs(0.00001 * xi) And Abs(yi - y2) < Abs(0.00001 * yi) Or _
(xi - x1) * (xi - x2) < 0 Or _
Abs(x1 - x2) < (0.0000001 * x1) And ((yi - y1) * (yi - y2) < 0) Then
If Abs(xi - x3) < Abs(0.00001 * xi) And Abs(yi - y3) < Abs(0.00001 * yi) Or _
Abs(xi - x4) < Abs(0.00001 * xi) And Abs(yi - y4) < Abs(0.00001 * yi) Or _
(xi - x3) * (xi - x4) < 0 Or _
Abs(x3 - x4) < Abs(0.000001 * yi) And ((yi - y3) * (yi - y4) < 0) Then
F = 1
End If
End If
Regards
Are you competent to do this or are you just trying to enjoy?Don't be so rude! I didn't want to bother you, I was just asking ;-)
Option Explicit
Public Function lngF(ByVal xi As Double, _
ByVal x1 As Double, _
ByVal x2 As Double, _
ByVal x3 As Double, _
ByVal x4 As Double, _
ByVal yi As Double, _
ByVal y1 As Double, _
ByVal y2 As Double, _
ByVal y3 As Double, _
ByVal y4 As Double) As Long
Dim F As Long
If Abs(xi - x1) < Abs(0.00001 * xi) And Abs(yi - y1) < Abs(0.00001 * yi) Then GoTo 10
If Abs(xi - x2) < Abs(0.00001 * xi) And Abs(yi - y2) < Abs(0.00001 * yi) Then GoTo 10
If Abs(x1 - x2) < (0.0000001 * x1) Then If (yi - y1) * (yi - y2) < 0 Then GoTo 10 Else GoTo 20
If (xi - x1) * (xi - x2) < 0 Then GoTo 10
GoTo 20
10:
If Abs(xi - x3) < Abs(0.00001 * xi) And Abs(yi - y3) < Abs(0.00001 * yi) Then GoTo 30
If Abs(xi - x4) < Abs(0.00001 * xi) And Abs(yi - y4) < Abs(0.00001 * yi) Then GoTo 30
If Abs(x3 - x4) < Abs(0.000001 * yi) Then If (yi - y3) * (yi - y4) < 0 Then GoTo 30 Else GoTo 20
If (xi - x3) * (xi - x4) < 0 Then GoTo 30
GoTo 20
30:
F = 1
20:
lngF = F
End Function
Public Function lngF_Rewritten(ByVal xi As Double, _
ByVal x1 As Double, _
ByVal x2 As Double, _
ByVal x3 As Double, _
ByVal x4 As Double, _
ByVal yi As Double, _
ByVal y1 As Double, _
ByVal y2 As Double, _
ByVal y3 As Double, _
ByVal y4 As Double) As Long
Dim blnSkip As Boolean
Dim F As Double
blnSkip = False
Select Case (True)
Case Abs(xi - x1) < Abs(0.00001 * xi) And Abs(yi - y1) < Abs(0.00001 * yi)
Case Abs(xi - x2) < Abs(0.00001 * xi) And Abs(yi - y2) < Abs(0.00001 * yi)
Case Abs(x1 - x2) < (0.0000001 * x1)
blnSkip = ((yi - y1) * (yi - y2) >= 0)
Case (xi - x1) * (xi - x2) < 0
Case Else
blnSkip = True
End Select ' Select Case (True)
If Not (blnSkip) Then
blnSkip = False
Select Case (True)
Case Abs(xi - x3) < Abs(0.00001 * xi) And Abs(yi - y3) < Abs(0.00001 * yi)
Case Abs(xi - x4) < Abs(0.00001 * xi) And Abs(yi - y4) < Abs(0.00001 * yi)
Case Abs(x3 - x4) < Abs(0.000001 * yi)
blnSkip = ((yi - y3) * (yi - y4) >= 0)
Case (xi - x3) * (xi - x4) < 0
Case Else
blnSkip = True
End Select ' Select Case (True)
End If ' If Not (blnSkip) Then
If Not (blnSkip) Then
F = 1
End If ' If Not (blnSkip) Then
lngF_Rewritten = F
End Function
Public Sub Test_Q_28322873()
Dim xi As Double
Dim x1 As Double
Dim x2 As Double
Dim x3 As Double
Dim x4 As Double
Dim yi As Double
Dim y1 As Double
Dim y2 As Double
Dim y3 As Double
Dim y4 As Double
Dim lngRow As Long
Application.StatusBar = "Processing - Please wait..."
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
[M1].AutoFilter
ActiveSheet.Cells.Clear
lngRow = 1&
Range(Cells(lngRow, 1), Cells(lngRow, 1).Offset(0&, 12)) = Array("xi", "x1", "x2", "x3", "x4", _
"yi", "y1", "y2", "y3", "y4", _
"Original F", _
"Rewritten F", _
"Difference")
For xi = 0# To 1# Step 0.5
For x1 = 0# To 1# Step 0.5
For x2 = 0# To 1# Step 0.5
For x3 = 0# To 1# Step 0.5
For x4 = 0# To 1# Step 0.5
For yi = 0# To 1# Step 0.5
For y1 = 0# To 1# Step 0.5
For y2 = 0# To 1# Step 0.5
For y3 = 0# To 1# Step 0.5
For y4 = 0# To 1# Step 0.5
lngRow = lngRow + 1&
Range(Cells(lngRow, 1), Cells(lngRow, 1).Offset(0&, 11)) = _
Array(xi, x1, x2, x3, x4, _
yi, y1, y2, y3, y4, _
lngF(xi, x1, x2, x3, x4, yi, y1, y2, y3, y4), _
lngF_Rewritten(xi, x1, x2, x3, x4, yi, y1, y2, y3, y4))
DoEvents
Next y4
Next y3
Next y2
Next y1
Next yi
Next x4
Next x3
Next x2
Next x1
Next xi
Range([M2], Cells(lngRow, "M")).FormulaR1C1 = "=RC[-2]-RC[-1]"
[M1].AutoFilter
ActiveSheet.Range([A1], Cells(lngRow, "M")).AutoFilter Field:=13, Criteria1:="<>0"
If Cells.SpecialCells(xlCellTypeLastCell).Row > 1& Then
Cells.SpecialCells(xlCellTypeVisible).EntireRow.Interior.ColorIndex = 3&
End If ' If Cells.SpecialCells(xlCellTypeLastCell).Row > 1& Then
ActiveSheet.Columns.AutoFit
Application.Goto Reference:=[A1], Scroll:=True
Application.StatusBar = "Finished" & _
IIf(Cells.SpecialCells(xlCellTypeLastCell).Row > 1&, _
"- Rewritten function failed!", _
" (both results match).")
Application.Calculation = xlCalculationAutomatic
[M1].AutoFilter
[M:M].Delete
Application.ScreenUpdating = True
MsgBox Application.StatusBar, _
vbInformation Or vbOKOnly, _
ThisWorkbook.Name
Application.StatusBar = False
End Sub
If you are experiencing a similar issue, please ask a related question
Title | # Comments | Views | Activity |
---|---|---|---|
MS Access 03, TransferText, decimal places | 8 | 45 | |
Excel VBA When using VLookup | 6 | 28 | |
Excel Automation VBA | 19 | 37 | |
Applying Background Image to All Sheets in Excel | 1 | 16 |
Join the community of 500,000 technology professionals and ask your questions.
Connect with top rated Experts
15 Experts available now in Live!