[VBA]两个数组的x值对比,如果不重复则插入到另一个数组中,请高手帮忙！

狐狸老兄

' 坐标点排序函数
' 语法：SortPoints(Points, 0)
' Points为坐标点数组
' SortMode为排序方式：0=X向，1=Y向，2=Z向
' 返回值为排序后的坐标点数组 Public Function SortPoints(Points As Variant, SortMode As Variant) As Variant

Dim NewPoints() As Variant
ReDim NewPoints(UBound(Points))
Dim k As Long
For k = 0 To UBound(NewPoints)
NewPoints(k) = Points(k)
Next k

Dim BestPoint As Variant
Dim m As Variant
Dim n As Variant
Dim j As Variant

Dim Best_Value As Double
Dim Best_n As Variant

For m = 0 To UBound(NewPoints) - 1
Best_Value = NewPoints(m)(SortMode)
BestPoint = NewPoints(m)
Best_n = m

For n = m + 1 To UBound(NewPoints)
If NewPoints(n)(SortMode) < Best_Value Then
Best_Value = NewPoints(n)(SortMode)
BestPoint = NewPoints(n)
Best_n = n
End If

Next n

NewPoints(Best_n) = NewPoints(m)
NewPoints(m) = BestPoint

Next m

SortPoints = NewPoints

End Function ' 示例
Sub FindLineStartPoint()
Dim Sel As AcadSelectionSet On Error Resume Next Set Sel = ThisDrawing.SelectionSets.Add("ssel") If Err Then
Err.Clear
ThisDrawing.SelectionSets("ssel").Delete
Set Sel = ThisDrawing.SelectionSets.Add("ssel")
End If
On Error GoTo 0 '选取地表曲线 Sel.SelectOnScreen '获取选取地表曲线起始点 Dim obj As AcadObject
Dim i As Integer
Dim Pa() As Variant
Dim k As Integer
k = Sel.Count
ReDim Pa(k - 1)
Dim str As String i = 0
str = "地表曲线未排序坐标"
For Each obj In Sel
If obj.ObjectName = "AcDbLine" Then
Pa(i) = obj.StartPoint
str = str & vbCr & " 第 " & i + 1 & " 点坐标为: " & Pa(i)(0) & " " & Pa(i)(1) & " " & Pa(i)(2)
i = i + 1
End If
Next
MsgBox str
'选取直线起始点排序 Pa = SortPoints(Pa, 0) NewTxt = "按X坐标点大小排序" For i = 0 To UBound(Pa)

NewTxt = NewTxt & vbCr & "第" & i + 1 & "点坐标为:" & Pa(i)(0) & " " & Pa(i)(1) & " " & Pa(i)(2)
Next MsgBox NewTxt Sel.Delete '选取埋地管线
Dim Selb As AcadSelectionSet
Dim objb As AcadObject
Set Selb = ThisDrawing.SelectionSets.Add("ssel") Selb.SelectOnScreen '获取选取埋地管线起始点 Dim Pb() As Variant
k = Selb.Count
ReDim Pb(k - 1)
i = 0
str = "埋地管线未排序坐标 " For Each objb In Selb
If objb.ObjectName = "AcDbLine" Then
Pb(i) = objb.StartPoint
str = str & vbCr & " 第 " & i + 1 & " 点坐标为: " & Pb(i)(0) & " " & Pb(i)(1) & " " & Pb(i)(2)
i = i + 1
End If
Next
MsgBox str Pb = SortPoints(Pb, 0) NewTxt = "埋地管线按X坐标点大小排序" For i = 0 To UBound(Pb)

NewTxt = NewTxt & vbCr & "第" & i + 1 & "点坐标为:" & Pb(i)(0) & " " & Pb(i)(1) & " " & Pb(i)(2)

Next MsgBox NewTxt


'地面曲线和麦地管线坐标数组排序 Dim m As Long
Dim j As Long
Dim e As Long
Dim X1 As Double
Dim X2 As Double
Dim Y1 As Double
Dim Y2 As Double
Dim Xk As Double
Dim Yk As Double
Dim Pc As Variant Pc = SortPoints(Pa, 0) For m = 0 To UBound(Pb) k = UBound(Pc)

j = 0

For i = 0 To k If Pc(i)(0) <> Pb(m)(0) Then j = j + 1

Next

ReDim Preserve Pc(k + 1)

If j = k Then Pc(k + 1) = Pb(m)

For e = 0 To UBound(Pc)

X1 = Pc(e)(0)
X2 = Pc(e + 1)(0)
Y1 = Pc(e)(1)
Y2 = Pc(e + 1)(1)
Xk = Pc(k)(0)
Yk = Pc(k)(1)


If Pc(e)(0) < Pc(k)(0) < Pc(e + 1)(0) Then Pc(k)(1) = (Xk - X1) / (X2 - X1) * Sqr((Y2 - Y1) ^ 2 + (X2 - X1) ^ 2): Pc(k)(2) = 0

Next

Pc = SortPoints(Pc, 0) Next
'Selb.Delete
End Sub

efan2000

For m = 0 To UBound(NewPoints) - 1
For n = m + 1 To UBound(NewPoints)
If NewPoints(n)(SortMode) < NewPoints(m)(SortMode) Then
BestPoint=NewPoints(n)
NewPoints(n)=NewPoints(m)
NewPoints(m) = n
End If
Next n
Next m