check distance difference based on criteria

[okl]

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

[StephenR]

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

[okl]

maybe should just use column A,B ,C .
E , F and G is the duplicate.


Example i select "P01" , it list out the PA13...etc where < 2000.

Then i select "P04" , it also will list out same Points PA13, PB08 where it match above.

As you see, distance from P01 to PPA13 is 1873. where P04 to PA13 is 1945. But still within 2000.

[StephenR]

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

[okl]

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

[okl]

use pivot ??

[StephenR]

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?

[okl]

exactly, sorry for my bad explanation.

[okl]

Pivot table possible ?

[StephenR]

OK try attachment - press the button.

[okl]

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

[StephenR]

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

Please Login or Register  to view this content.

[okl]

sorry , another error.

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

run time error "13", type mismatch ?

[StephenR]

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

Please Login or Register  to view this content.

[okl]

sorry , error again.

Set Distance 800
Pt A P01
Pt B P04

[StephenR]

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

Please Login or Register  to view this content.

[okl]

even i key 2000, it give me no point found too. point is available.

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


If n = 0 Then GoTo Err

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

Err:

MsgBox "No points found"

Application.ScreenUpdating = True

End Sub

[StephenR]

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

[okl]

Same point too?? 1and4

[okl]

Can attach your workbook for me to confirm again?


or is the code correct in sequence?

Please Login or Register  to view this content.

[StephenR]

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