check distance difference based on criteria

Hi,

I have a Point A to Point B with the distance.

1. user can set a adjustable distance in cell J1. e.g 2000

2. User select Point A.

3. User select Point B

4. Then list out all the Point C where distance diff between Point A and Point B all within 2000.

any solution please ?

Thanks


Thanks

Am I missing something? The A and B ranges look identical.

OK, but what do you want to do with the results? If you just want to see them, couldn't you just use AutoFilter?

But i got all list of point Bs from P04 where < 2000.

HTML Code: 

use pivot ??

I think I'm starting to understand. So you want to select e.g. PO1 and find all the rows where distance <2000. Then select another, e.g. PO4, again find all the rows where distance <2000 and then the result you want is the Pt Cs which are in both sets. Is that right?

exactly, sorry for my bad explanation.

Pivot table possible ?

OK try attachment - press the button.

great, but if i try Pt A = P01 , PtB = P10 , distance = 800 , it prompt me run time error "1004"

That's because there are no points. Try adding the section in the starred lines to avoid the error:

'Insert this bit
*********************************
If n = 0 Then
    MsgBox "No points found"
    Exit Sub
End If
*********************************
'Bit below already there
With Sheet2
    .UsedRange.Clear
    .Range("A1").Resize(n, 3) = vData3
End With

sorry , another error.

it distance = 500 , pt A = p01 , pt B = P04,

run time error "13", type mismatch ?

Try this. Messy code, but I think we're lurching towards a destination.

Sub x()
 
Dim rData As Range, vData, vData2, vData3(), n As Long, r As Long
Dim oDic1 As Object, oDic2 As Object

Application.ScreenUpdating = False

Set oDic1 = CreateObject("Scripting.Dictionary")
Set oDic2 = CreateObject("Scripting.Dictionary")

With Sheet1
    .AutoFilterMode = False
    .Range("A1").AutoFilter Field:=1, Criteria1:=.Range("J2").Value
    .Range("A1").AutoFilter Field:=3, Criteria1:="<" & .Range("J1").Value
    With .AutoFilter.Range
        On Error Resume Next
        Set rData = .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible)
        On Error GoTo 0
        If Not rData Is Nothing Then
            vData = rData.Value
        Else
            GoTo Err
        End If
    End With
    Set rData = Nothing
    .Range("A1").AutoFilter Field:=1, Criteria1:=.Range("J3").Value
    With .AutoFilter.Range
        On Error Resume Next
        Set rData = .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible)
        On Error GoTo 0
        If Not rData Is Nothing Then
            vData2 = rData.Value
        Else
            GoTo Err
        End If
    End With
    .AutoFilterMode = False
End With

ReDim vData3(1 To UBound(vData, 1) + UBound(vData2, 1), 1 To 3)

For r = LBound(vData, 1) To UBound(vData, 1)
    If Not IsEmpty(vData(r, 2)) And Not oDic1.exists(vData(r, 2)) Then
        n = n + 1
        oDic1.Add vData(r, 2), n
    End If
Next r
n = 0
For r = LBound(vData2, 1) To UBound(vData2, 1)
    If Not IsEmpty(vData2(r, 2)) And Not oDic2.exists(vData2(r, 2)) Then
        n = n + 1
        oDic2.Add vData2(r, 2), n
    End If
Next r
n = 0
For r = LBound(vData, 1) To UBound(vData, 1)
    If oDic1.exists(vData(r, 2)) And oDic2.exists(vData(r, 2)) Then
        n = n + 1
        vData3(n, 1) = Sheet1.Range("J2") & "/" & Sheet1.Range("J3")
        vData3(n, 2) = vData(r, 2)
        vData3(n, 3) = vData(r, 3)
    End If
Next r

With Sheet2
    .UsedRange.Clear
    .Range("A1").Resize(n, 3) = vData3
End With

Application.ScreenUpdating = True
Exit Sub

Err:

MsgBox "No points found"

Application.ScreenUpdating = True
        
End Sub

sorry , error again.

Set Distance 800
Pt A P01
Pt B P04

Dearie me, I'm doing well here aren't I. Try adding the first line below which I inadvertently removed last time.

If n = 0 Then GoTo Err

With Sheet2
    .UsedRange.Clear
    .Range("A1").Resize(n, 3) = vData3
End With

Which points? With P01/P04 I get 7 results.

Same point too?? 1and4

See attachment. I'm losing confidence in this approach. Might be easier to go back to the drawing board.