如何计算重复路段

gzqdnzys

需要统计相同路线编码，起终点有交叉的情况，请高手帮助。
如附表中的X001，分为了两段，分别是[0,2]，[1.5,3]，其中[1.5-2]就属于重复路段，需要统计出重复路段的桩号及路线编码

gzqdnzys

图中红色为判别结果

一把小刀闯天下

Option Explicit

Sub test()
  Dim arr, i, j
  arr = [a2].CurrentRegion
  ReDim brr(1 To UBound(arr, 1), 1 To 1)
  For i = 2 To UBound(arr, 1)
    For j = i + 1 To UBound(arr, 1)
      If arr(i, 1) = arr(j, 1) Then
        If arr(j, 2) < arr(i, 3) And arr(j, 2) > arr(i, 2) Or _
        arr(j, 3) < arr(i, 3) And arr(j, 3) > arr(i, 2) Then
          brr(i, 1) = "[" & arr(i, 2) & "," & arr(i, 3) & "]" & "-" & _
          "[" & arr(j, 2) & "," & arr(j, 3) & "]"
          brr(j, 1) = "[" & arr(j, 2) & "," & arr(j, 3) & "]" & "-" & _
          "[" & arr(i, 2) & "," & arr(i, 3) & "]"
        End If
      End If
  Next j, i
  [d2].Resize(UBound(brr, 1)) = brr
End Sub

gzqdnzys

感谢 一把小刀闯天下 的帮助

gzqdnzys

一把小刀闯天下 发表于 2018-8-6 19:51
Option Explicit

Sub test()

再请教，如果X001分了三段及以上，分别是[0,2]，[1.5,3]，[0.5,1.6]，[2,2.5]，能不能把所有重复段都找出来？如：
[0,2]段，重复情况为[0,2]，[1.5,3]
[1.5,3]段，重复情况为[1.5,3]，[0,2]，[0.5,1.6]，[2,2.5]
[0.5,1.6]段，重复情况为[0.5,1.6]，[1.5,3]，[0,2]
[2,2.5]段，重复情况为[2,2.5]，[1.5,3]

一把小刀闯天下

gzqdnzys 发表于 2018-8-11 08:22
再请教，如果X001分了三段及以上，分别是[0,2]，[1.5,3]，[0.5,1.6]，[2,2.5]，能不能把所有重复段都找出 ...

'没有新附件，还是用1楼的附件测试的，未作多重复编码作测试,估计差不多

'满意来朵小花，这代码效率不会差。改成通用了，修改起来非常方便

Option Explicit

Sub test()
  Dim arr, i, j, t, dic, s
  Set dic = CreateObject("scripting.dictionary")
  arr = Range("a3:c" & Cells(Rows.Count, "a").End(xlUp).Row)
  ReDim brr(1 To UBound(arr, 1), 1 To 1)
  For i = 1 To UBound(arr, 1)
    If dic.exists(arr(i, 1)) Then
      t = dic(arr(i, 1))
      ReDim Preserve t(2, UBound(t, 2) + 1)
      t(1, UBound(t, 2)) = arr(i, 2): t(2, UBound(t, 2)) = arr(i, 3)
    Else
      ReDim t(2, 0)
      t(1, 0) = arr(i, 2): t(2, 0) = arr(i, 3)
    End If
    t(0, UBound(t, 2)) = i
    dic(arr(i, 1)) = t
  Next
  For i = 1 To UBound(arr, 1)
    t = dic(arr(i, 1)): s = vbNullString
    For j = 0 To UBound(t, 2)
      If i <> t(0, j) Then
         If arr(i, 2) > t(1, j) And arr(i, 2) < t(2, j) Or _
          arr(i, 3) < t(2, j) And arr(i, 3) > t(1, j) Then
          If Len(s) = 0 Then s = "[" & arr(i, 2) & "," & arr(i, 3) & "]"
          s = s & "-" & "[" & t(1, j) & "," & t(2, j) & "]"
        End If
      End If
    Next
    If Len(s) Then brr(i, 1) = s
  Next
  [d3].Resize(UBound(brr, 1)) = brr
End Sub