Страницы: 1
RSS
Нахождение маршрутов которые дублируют друг друга полностью и практически полностью"
 
Коллеги, всем привет! Помоги, пожалуйста, решить задачу в Excel, очень хочется разобраться, как это сделать. Имеется таблица данных (ниже прикладываю ее), таблица содержит несколько столбцов, а именно номер маршрута, порядок остановок в процессе движения (прямое и обратное направление) и географические координаты места остановки (координаты на пути туда и обратно отличаются). Задание: определить маршруты которые дублируют друг друга полностью и практически полностью (без одной/двух остановок или наоборот плюс одна/две остановки)
Изменено: Юрий М - 17.08.2022 12:25:50
 
файл забыли приложить
 
не загрузился почему-то, спасибо, что написали  
Изменено: Guzunda88 - 17.08.2022 13:09:20
 
Цитата
Guzunda88 написал:
практически полностью (без одной/двух остановок или наоборот плюс одна/две остановки)
Guzunda88, я смотрю Вы добавили еще одно условие о не полном соответствии (по сравнению с Вашей темой в разделе Работа)
Для Модераторов - название темы "Нахождение маршрутов которые дублируют друг друга полностью и практически полностью"
Кто ясно мыслит, тот ясно излагает.
 
Цитата
написал:
Цитата
Guzunda88 написал:
практически полностью (без одной/двух остановок или наоборот плюс одна/две остановки)
Guzunda88, я смотрю Вы добавили еще одно условие о не полном соответствии (по сравнению с Вашей темой в разделе Работа)
Для Модераторов - название темы "Нахождение маршрутов которые дублируют друг друга полностью и практически полностью"
Да, добавил, вдруг второе условие тоже несложно выполнимое, а так хотя бы с основным разобраться)
 
Дубль в платной ветке
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
 
если получится решить задачу с полным соответствием - будет уже хорошо
Изменено: Guzunda88 - 17.08.2022 13:33:01
 
Guzunda88,  у Вас не цитаты, а полные копии предыдущих сообщений. Приведите в порядок свои #3 и #7.
И запомните - кнопка цитирования не для ответа!
 
Все поправил
Изменено: Guzunda88 - 17.08.2022 13:33:24
 
Цитата
написал:
решить задачу с полным соответствием
Код
Sub FindMarch()
    Dim yy As Long
    Dim arr As Variant
    With ActiveSheet
        yy = .Cells(.Rows.Count, 1).End(xlUp).Row
        arr = Cells(2, 1).Resize(yy - 1, 7)
    End With
    
    Dim dicY As Object
    Set dicY = CreateObject("Scripting.Dictionary")
    For yy = UBound(arr, 1) To LBound(arr, 1) Step -1
        dicY.Item(arr(yy, 6) & vbTab & arr(yy, 7)) = yy
    Next
    
    Dim dicM As Object
    Set dicM = CreateObject("Scripting.Dictionary")
    dicM.CompareMode = 1
    For yy = LBound(arr, 1) To UBound(arr, 1)
        dicM.Item(arr(yy, 2)) = dicM.Item(arr(yy, 2)) & vbTab & dicY.Item(arr(yy, 6) & vbTab & arr(yy, 7))
    Next
    
    Dim aKeys As Variant
    Dim aItem As Variant
    aKeys = dicM.Keys()
    aItem = dicM.Items()
    
    Dim uu As Long
    Dim res As Variant
    For yy = 0 To UBound(aKeys) - 1
        For uu = yy + 1 To UBound(aKeys)
            If aItem(yy) = aItem(uu) Then
                If IsEmpty(res) Then
                    ReDim res(1 To 1)
                Else
                    ReDim Preserve res(1 To UBound(res) + 1)
                End If
                res(UBound(res)) = aKeys(yy) & " = " & aKeys(uu)
            End If
        Next
    Next
    If IsEmpty(res) Then
        MsgBox "Совпадений не найдено.", vbInformation, "March"
    Else
        MsgBox Join(res, vbLf), vbInformation, "March"
    End If
End Sub
 
МатросНаЗебре, спасибо большое, сейчас проверю!
 
Guzunda88, решение в Power Query (полное соответствие).
Кто ясно мыслит, тот ясно излагает.
 
Guzunda88,
странный вариант
 
evgeniygeo, почему странный ?
 
Maximich, на данный момент, если я все правильно проверяю, то таблица показывает совпадение по определенным остановкам, не по маршруту
 
Цитата
Guzunda88 написал:
таблица показывает совпадение по определенным остановкам
Таблица показывает 100% совпадение остановок на маршруте
Кто ясно мыслит, тот ясно излагает.
 
Цитата
Guzunda88 написал:
Лист Microsoft Excel (4).xlsx
Код
=СЧЁТЕСЛИМН(E$2:E2;E2;F$2:F2;F2;G$2:G2;G2;B$2:B2;B2)

Номер маршрута при необходимости можно и не учитывать
 
Guzunda88,
мне кажется, что он слишком замороченный, поэтому странный.
Я слегка упростил его во вложении.
Цитата
Guzunda88 написал:
почему странный ?
 
Все остановки маршрута 50 являются остановками маршрута 43.
Код
Option Explicit

Sub FindMarch2()
    Dim yy As Long
    Dim arr As Variant
    With ActiveSheet
        yy = .Cells(.Rows.Count, 1).End(xlUp).Row
        arr = Cells(2, 1).Resize(yy - 1, 7)
    End With
    
    Dim dicY As Object
    Set dicY = CreateObject("Scripting.Dictionary")
    For yy = UBound(arr, 1) To LBound(arr, 1) Step -1
        dicY.Item(arr(yy, 6) & vbTab & arr(yy, 7)) = yy
    Next
    
    Dim dicM As Object
    Set dicM = CreateObject("Scripting.Dictionary")
    dicM.CompareMode = 1
    For yy = LBound(arr, 1) To UBound(arr, 1)
        If Not dicM.Exists(arr(yy, 2)) Then
            Set dicM.Item(arr(yy, 2)) = CreateObject("Scripting.Dictionary")
            dicM.Item(arr(yy, 2)).CompareMode = 1
        End If
        dicM.Item(arr(yy, 2)).Item(arr(yy, 6) & vbTab & arr(yy, 7)) = 0
    Next
    
    If dicM.Count < 2 Then Exit Sub
    
    Dim res As Variant
    Dim yres As Long
    ReDim res(1 To dicM.Count * (dicM.Count - 1) + 1, 1 To 5)
    yres = 1
    res(yres, 1) = "Маршрут 1"
    res(yres, 2) = "Маршрут 2"
    res(yres, 3) = "Точек совпало"
    res(yres, 4) = "Точек на маршруте 1"
    res(yres, 5) = "Совпадение"
        
    Dim mars1 As Variant
    Dim mars2 As Variant
    Dim point1 As Variant
    Dim points1 As Variant
    Dim nn As Long
    For Each mars1 In dicM.Keys
        If dicM.Item(mars1).Count > 1 Then
            points1 = dicM.Item(mars1).Keys()
            For Each mars2 In dicM.Keys
                If mars1 <> mars2 Then
                    nn = 0
                    For Each point1 In points1
                        If dicM.Item(mars2).Exists(point1) Then nn = nn + 1
                    Next
                    yres = yres + 1
                    res(yres, 1) = mars1
                    res(yres, 2) = mars2
                    res(yres, 3) = nn
                    res(yres, 4) = dicM.Item(mars1).Count
                    res(yres, 5) = res(yres, 3) / res(yres, 4)
                End If
            Next
        End If
    Next
        
    OutPutArr res
End Sub
Private Sub OutPutArr(arr As Variant)
    With Workbooks.Add(1)
        With .Sheets(1)
            Dim rr As Range
            Set rr = .Cells(1, 1).Resize(UBound(arr, 1), UBound(arr, 2))
            With rr
                .Columns("A:B").NumberFormat = "@"
                .Columns(5).NumberFormat = "0%"
                .Value = arr
            End With
            
            .Sort.SortFields.Clear
            .Sort.SortFields.Add Key:=rr.Columns(5), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
            .Sort.SortFields.Add Key:=rr.Columns(4), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
            .Sort.SortFields.Add Key:=rr.Columns(1), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            .Sort.SortFields.Add Key:=rr.Columns(2), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            .Sort.SortFields.Add Key:=rr.Columns(3), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            With .Sort
                .SetRange rr
                .Header = xlYes
                .MatchCase = False
                .Orientation = xlTopToBottom
                .SortMethod = xlPinYin
                .Apply
            End With
        End With
        .Saved = True
    End With
End Sub

 
Код
Option Explicit
 
Sub FindMarch3()
    Dim yy As Long
    Dim arr As Variant
    With ActiveSheet
        yy = .Cells(.Rows.Count, 1).End(xlUp).Row
        arr = Cells(2, 1).Resize(yy - 1, 7)
    End With
     
    Dim dicY As Object
    Set dicY = CreateObject("Scripting.Dictionary")
    For yy = UBound(arr, 1) To LBound(arr, 1) Step -1
        dicY.Item(arr(yy, 6) & vbTab & arr(yy, 7)) = yy
    Next
     
    Dim sKey As String
    Dim dicM As Object
    Set dicM = CreateObject("Scripting.Dictionary")
    dicM.CompareMode = 1
    For yy = LBound(arr, 1) To UBound(arr, 1)
        sKey = arr(yy, 1) & " - " & arr(yy, 2)
        If Not dicM.Exists(sKey) Then
            Set dicM.Item(sKey) = CreateObject("Scripting.Dictionary")
            dicM.Item(sKey).CompareMode = 1
        End If
        dicM.Item(sKey).Item(arr(yy, 6) & vbTab & arr(yy, 7)) = 0
    Next
     
    If dicM.Count < 2 Then Exit Sub
     
    Dim res As Variant
    Dim yres As Long
    ReDim res(1 To dicM.Count * (dicM.Count - 1) + 1, 1 To 5)
    yres = 1
    res(yres, 1) = "Маршрут 1"
    res(yres, 2) = "Маршрут 2"
    res(yres, 3) = "Точек совпало"
    res(yres, 4) = "Точек на маршруте 1"
    res(yres, 5) = "Совпадение"
         
    Dim mars1 As Variant
    Dim mars2 As Variant
    Dim point1 As Variant
    Dim points1 As Variant
    Dim nn As Long
    For Each mars1 In dicM.Keys
        If dicM.Item(mars1).Count > 1 Then
            points1 = dicM.Item(mars1).Keys()
            For Each mars2 In dicM.Keys
                If mars1 <> mars2 Then
                    nn = 0
                    For Each point1 In points1
                        If dicM.Item(mars2).Exists(point1) Then nn = nn + 1
                    Next
                    yres = yres + 1
                    res(yres, 1) = mars1
                    res(yres, 2) = mars2
                    res(yres, 3) = nn
                    res(yres, 4) = dicM.Item(mars1).Count
                    res(yres, 5) = res(yres, 3) / res(yres, 4)
                End If
            Next
        End If
    Next
         
    OutPutArr res
End Sub
Private Sub OutPutArr(arr As Variant)
    With Workbooks.Add(1)
        With .Sheets(1)
            Dim rr As Range
            Set rr = .Cells(1, 1).Resize(UBound(arr, 1), UBound(arr, 2))
            With rr
                .Columns("A:B").NumberFormat = "@"
                .Columns(5).NumberFormat = "0%"
                .Value = arr
            End With
             
            .Sort.SortFields.Clear
            .Sort.SortFields.Add Key:=rr.Columns(5), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
            .Sort.SortFields.Add Key:=rr.Columns(4), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
            .Sort.SortFields.Add Key:=rr.Columns(1), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            .Sort.SortFields.Add Key:=rr.Columns(2), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            .Sort.SortFields.Add Key:=rr.Columns(3), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            With .Sort
                .SetRange rr
                .Header = xlYes
                .MatchCase = False
                .Orientation = xlTopToBottom
                .SortMethod = xlPinYin
                .Apply
            End With
        End With
        .Saved = True
    End With
End Sub
 
Код
Option Explicit
  
Sub FindMarch4()
    Dim yy As Long
    Dim arr As Variant
    With ActiveSheet
        yy = .Cells(.Rows.Count, 2).End(xlUp).Row
        arr = Cells(2, 1).Resize(yy - 1, 8)
    End With
      
    Dim dicY As Object
    Set dicY = CreateObject("Scripting.Dictionary")
    For yy = UBound(arr, 1) To LBound(arr, 1) Step -1
        dicY.Item(arr(yy, 7) & vbTab & arr(yy, 8)) = yy
    Next
      
    Dim sKey As String
    Dim dicM As Object
    Set dicM = CreateObject("Scripting.Dictionary")
    dicM.CompareMode = 1
    For yy = LBound(arr, 1) To UBound(arr, 1)
        sKey = arr(yy, 2) & " - " & arr(yy, 3)
        If Not dicM.Exists(sKey) Then
            Set dicM.Item(sKey) = CreateObject("Scripting.Dictionary")
            dicM.Item(sKey).CompareMode = 1
        End If
        dicM.Item(sKey).Item(arr(yy, 7) & vbTab & arr(yy, 8)) = 0
    Next
      
    If dicM.Count < 2 Then Exit Sub
      
    Dim res As Variant
    Dim yres As Long
    ReDim res(1 To dicM.Count * (dicM.Count - 1) + 1, 1 To 5)
    yres = 1
    res(yres, 1) = "Маршрут 1"
    res(yres, 2) = "Маршрут 2"
    res(yres, 3) = "Точек совпало"
    res(yres, 4) = "Точек на маршруте 1"
    res(yres, 5) = "Совпадение"
          
    Dim mars1 As Variant
    Dim mars2 As Variant
    Dim point1 As Variant
    Dim points1 As Variant
    Dim nn As Long
    For Each mars1 In dicM.Keys
        If dicM.Item(mars1).Count > 1 Then
            points1 = dicM.Item(mars1).Keys()
            For Each mars2 In dicM.Keys
                If mars1 <> mars2 Then
                    nn = 0
                    For Each point1 In points1
                        If dicM.Item(mars2).Exists(point1) Then nn = nn + 1
                    Next
                    yres = yres + 1
                    res(yres, 1) = mars1
                    res(yres, 2) = mars2
                    res(yres, 3) = nn
                    res(yres, 4) = dicM.Item(mars1).Count
                    res(yres, 5) = res(yres, 3) / res(yres, 4)
                End If
            Next
        End If
    Next
          
    OutPutArr res
End Sub
Private Sub OutPutArr(arr As Variant)
    With Workbooks.Add(1)
        With .Sheets(1)
            Dim rr As Range
            Set rr = .Cells(1, 1).Resize(UBound(arr, 1), UBound(arr, 2))
            With rr
                .Columns("A:B").NumberFormat = "@"
                .Columns(5).NumberFormat = "0%"
                .Value = arr
            End With
              
            .Sort.SortFields.Clear
            .Sort.SortFields.Add Key:=rr.Columns(5), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
            .Sort.SortFields.Add Key:=rr.Columns(4), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
            .Sort.SortFields.Add Key:=rr.Columns(1), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            .Sort.SortFields.Add Key:=rr.Columns(2), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            .Sort.SortFields.Add Key:=rr.Columns(3), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            With .Sort
                .SetRange rr
                .Header = xlYes
                .MatchCase = False
                .Orientation = xlTopToBottom
                .SortMethod = xlPinYin
                .Apply
            End With
        End With
        .Saved = True
    End With
End Sub
 
Спасибо, но у меня все равно почему-то не получается открыть. Выдает ошибку "Run-time error '1004: Application-defined or object defind error"
 
вот эту строчку подсвечивает желтым
Set rr = .Cells(1, 1).Resize(UBound(arr, 1), UBound(arr, 2))
 
Во втором столбце пусто? Должен быть № м-та.
 
во втором столбце номер маршрута и они проставлены
 
Код
Option Explicit
   
Sub FindMarch5()
    Dim yy As Long
    Dim arr As Variant
    With ActiveSheet
        yy = .Cells(.Rows.Count, 2).End(xlUp).Row
        arr = Cells(2, 1).Resize(yy - 1, 8)
    End With
       
    Dim dicY As Object
    Set dicY = CreateObject("Scripting.Dictionary")
    For yy = UBound(arr, 1) To LBound(arr, 1) Step -1
        dicY.Item(arr(yy, 7) & vbTab & arr(yy, 8)) = yy
    Next
       
    Dim sKey As String
    Dim dicM As Object
    Set dicM = CreateObject("Scripting.Dictionary")
    dicM.CompareMode = 1
    For yy = LBound(arr, 1) To UBound(arr, 1)
        sKey = arr(yy, 2) & " - " & arr(yy, 3)
        If Not dicM.Exists(sKey) Then
            Set dicM.Item(sKey) = CreateObject("Scripting.Dictionary")
            dicM.Item(sKey).CompareMode = 1
        End If
        dicM.Item(sKey).Item(arr(yy, 7) & vbTab & arr(yy, 8)) = 0
    Next
       
    If dicM.Count < 2 Then Exit Sub
       
    Dim res As Variant
    Dim yres As Long
    ReDim res(1 To Application.Min(Rows.Count, dicM.Count * (dicM.Count - 1) + 1), 1 To 5)
    yres = 1
    res(yres, 1) = "Маршрут 1"
    res(yres, 2) = "Маршрут 2"
    res(yres, 3) = "Точек совпало"
    res(yres, 4) = "Точек на маршруте 1"
    res(yres, 5) = "Совпадение"
           
    Dim mars1 As Variant
    Dim mars2 As Variant
    Dim point1 As Variant
    Dim points1 As Variant
    Dim nn As Long
    For Each mars1 In dicM.Keys
        If dicM.Item(mars1).Count > 1 Then
            points1 = dicM.Item(mars1).Keys()
            For Each mars2 In dicM.Keys
                If mars1 <> mars2 Then
                    nn = 0
                    For Each point1 In points1
                        If dicM.Item(mars2).Exists(point1) Then nn = nn + 1
                    Next
                    yres = yres + 1
                    If yres <= UBound(res, 1) Then
                        res(yres, 1) = mars1
                        res(yres, 2) = mars2
                        res(yres, 3) = nn
                        res(yres, 4) = dicM.Item(mars1).Count
                        res(yres, 5) = res(yres, 3) / res(yres, 4)
                    End If
                End If
            Next
        End If
    Next
           
    OutPutArr res
End Sub
Private Sub OutPutArr(arr As Variant)
    With Workbooks.Add(1)
        With .Sheets(1)
            Dim rr As Range
            Set rr = .Cells(1, 1).Resize(UBound(arr, 1), UBound(arr, 2))
            With rr
                .Columns("A:B").NumberFormat = "@"
                .Columns(5).NumberFormat = "0%"
                .Value = arr
            End With
               
            .Sort.SortFields.Clear
            .Sort.SortFields.Add Key:=rr.Columns(5), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
            .Sort.SortFields.Add Key:=rr.Columns(4), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
            .Sort.SortFields.Add Key:=rr.Columns(1), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            .Sort.SortFields.Add Key:=rr.Columns(2), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            .Sort.SortFields.Add Key:=rr.Columns(3), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            With .Sort
                .SetRange rr
                .Header = xlYes
                .MatchCase = False
                .Orientation = xlTopToBottom
                .SortMethod = xlPinYin
                .Apply
            End With
        End With
        .Saved = True
    End With
End Sub
 
все работает теперь, спасибо
 
Код
Option Explicit

Sub FindMarch6()
    
    Dim yy As Long
    Dim arr As Variant
    With ActiveSheet
        yy = .Cells(.Rows.Count, 2).End(xlUp).Row
        arr = Cells(2, 1).Resize(yy - 1, 8)
    End With
        
    Dim dicY As Object
    Set dicY = CreateObject("Scripting.Dictionary")
    For yy = UBound(arr, 1) To LBound(arr, 1) Step -1
        dicY.Item(arr(yy, 7) & vbTab & arr(yy, 8)) = yy
    Next
        
    Dim sKey As String
    Dim dicM As Object
    Set dicM = CreateObject("Scripting.Dictionary")
    dicM.CompareMode = 1
    For yy = LBound(arr, 1) To UBound(arr, 1)
        sKey = arr(yy, 2) & " - " & arr(yy, 3)
        If Not dicM.Exists(sKey) Then
            Set dicM.Item(sKey) = CreateObject("Scripting.Dictionary")
            dicM.Item(sKey).CompareMode = 1
        End If
        dicM.Item(sKey).Item(arr(yy, 7) & vbTab & arr(yy, 8)) = 0
    Next
        
    If dicM.Count < 2 Then Exit Sub
        
    Dim res As Variant
    Dim yres As Long
    yres = 1
    InitResArray res, Application.Min(ActiveSheet.Rows.Count - 1, dicM.Count * (dicM.Count - 1) + 1)
            
    Dim rOut As Range
    Set rOut = Workbooks.Add(1).Sheets(1).Cells(1, 1)
            
    Dim mars1 As Variant
    Dim mars2 As Variant
    Dim point1 As Variant
    Dim points1 As Variant
    Dim nn As Long
    For Each mars1 In dicM.Keys
        If dicM.Item(mars1).Count > 1 Then
            points1 = dicM.Item(mars1).Keys()
            For Each mars2 In dicM.Keys
                If mars1 <> mars2 Then
                    nn = 0
                    For Each point1 In points1
                        If dicM.Item(mars2).Exists(point1) Then nn = nn + 1
                    Next
                    yres = yres + 1
                    If yres > UBound(res, 1) Then
                        OutPutArr res, rOut
                        InitResArray res, ActiveSheet.Rows.Count - 1
                        yres = 2
                    End If
                        
                    res(yres, 1) = mars1
                    res(yres, 2) = mars2
                    res(yres, 3) = nn
                    res(yres, 4) = dicM.Item(mars1).Count
                    res(yres, 5) = res(yres, 3) / res(yres, 4)

                End If
            Next
        End If
    Next
            
    OutPutArr res, rOut
End Sub
Private Sub OutPutArr(arr As Variant, rOut As Range)
    With rOut.Parent
        Dim rr As Range
        Set rr = rOut.Resize(UBound(arr, 1), UBound(arr, 2))
        With rr
            .Columns("A:B").NumberFormat = "@"
            .Columns(5).NumberFormat = "0%"
            .Value = arr
        End With
            
        .Sort.SortFields.Clear
        .Sort.SortFields.Add Key:=rr.Columns(5), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
        .Sort.SortFields.Add Key:=rr.Columns(4), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
        .Sort.SortFields.Add Key:=rr.Columns(1), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .Sort.SortFields.Add Key:=rr.Columns(2), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .Sort.SortFields.Add Key:=rr.Columns(3), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        With .Sort
            .SetRange rr
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
    End With
    
    Set rOut = rOut.Cells(1, UBound(arr, 2) + 2)
    rOut.Select
End Sub

Private Sub InitResArray(res As Variant, nn As Long)
    ReDim res(1 To nn, 1 To 5)
    res(1, 1) = "Маршрут 1"
    res(1, 2) = "Маршрут 2"
    res(1, 3) = "Точек совпало"
    res(1, 4) = "Точек на маршруте 1"
    res(1, 5) = "Совпадение"
End Sub

 
С сортировкой по всем диапазонам.
Код
Option Explicit

Const NMAX = 100000

Sub FindMarch7()
'    On Error Resume Next
'    Workbooks(2).Close False
'    On Error GoTo 0

    Dim yy As Long
    Dim arr As Variant
    With ActiveSheet
        yy = .Cells(.Rows.Count, 2).End(xlUp).Row
        arr = Cells(2, 1).Resize(yy - 1, 8)
    End With
        
    Dim dicY As Object
    Set dicY = CreateObject("Scripting.Dictionary")
    For yy = UBound(arr, 1) To LBound(arr, 1) Step -1
        dicY.Item(arr(yy, 7) & vbTab & arr(yy, 8)) = yy
    Next
        
    Dim sKey As String
    Dim dicM As Object
    Set dicM = CreateObject("Scripting.Dictionary")
    dicM.CompareMode = 1
    For yy = LBound(arr, 1) To UBound(arr, 1)
        sKey = arr(yy, 2) & " - " & arr(yy, 3)
        If Not dicM.Exists(sKey) Then
            Set dicM.Item(sKey) = CreateObject("Scripting.Dictionary")
            dicM.Item(sKey).CompareMode = 1
        End If
        dicM.Item(sKey).Item(arr(yy, 7) & vbTab & arr(yy, 8)) = 0
    Next
        
    If dicM.Count < 2 Then Exit Sub
        
    Dim res As Variant
    Dim yres As Long
    yres = 1
    InitResArray res, Application.Min(NMAX, dicM.Count * (dicM.Count - 1) + 1)
            
    Dim rOut As Range
    Set rOut = Workbooks.Add(1).Sheets(1).Cells(1, 1)
            
    Dim rOutAreas As Range
            
    Dim mars1 As Variant
    Dim mars2 As Variant
    Dim point1 As Variant
    Dim points1 As Variant
    Dim nn As Long
    For Each mars1 In dicM.Keys
        If dicM.Item(mars1).Count > 1 Then
            points1 = dicM.Item(mars1).Keys()
            For Each mars2 In dicM.Keys
                If mars1 <> mars2 Then
                    nn = 0
                    For Each point1 In points1
                        If dicM.Item(mars2).Exists(point1) Then nn = nn + 1
                    Next
                    yres = yres + 1
                    If yres > UBound(res, 1) Then
                        OutPutArr res, rOut, rOutAreas
                        InitResArray res, NMAX
                        yres = 2
                    End If
                        
                    res(yres, 1) = mars1
                    res(yres, 2) = mars2
                    res(yres, 3) = nn
                    res(yres, 4) = dicM.Item(mars1).Count
                    res(yres, 5) = res(yres, 3) / res(yres, 4)

                End If
            Next
        End If
    Next
            
    OutPutArr res, rOut, rOutAreas
    LongSort rOutAreas
    InvertOutAreas rOutAreas
End Sub

Private Sub InvertOutAreas(rOutAreas As Range)
    Dim ar1 As Variant
    Dim ar2 As Variant
    Dim xx As Long
    For xx = 1 To rOutAreas.Areas.Count / 2
        ar1 = rOutAreas.Areas(xx)
        ar2 = rOutAreas.Areas(rOutAreas.Areas.Count - xx + 1)
        rOutAreas.Areas(xx) = ar2
        rOutAreas.Areas(rOutAreas.Areas.Count - xx + 1) = ar1
    Next
    ar1 = Empty
    ar2 = Empty
    
    For xx = 1 To rOutAreas.Areas.Count
        With rOutAreas.Parent.Sort
            .SortFields.Clear
            .SortFields.Add Key:=rOutAreas.Areas(xx).Columns(5), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
            .SetRange rOutAreas.Areas(xx): .Header = xlNo: .MatchCase = False: .Orientation = xlTopToBottom: .SortMethod = xlPinYin
            .Apply
        End With
    Next
    
End Sub

Private Sub OutPutArr(arr As Variant, rOut As Range, rOutAreas As Range)
    With rOut.Parent
        Dim rr As Range
        Set rr = rOut.Resize(UBound(arr, 1), UBound(arr, 2))
        With rr
            .Columns("A:B").NumberFormat = "@"
            .Columns(5).NumberFormat = "0%"
            .Value = arr
        End With
        If rOutAreas Is Nothing Then
            Set rOutAreas = rOut.Cells(2, 1).Resize(UBound(arr, 1) - 1, UBound(arr, 2))
        Else
            Set rOutAreas = Union(rOutAreas, rOut.Cells(2, 1).Resize(UBound(arr, 1) - 1, UBound(arr, 2)))
        End If
            
        .Sort.SortFields.Clear
        .Sort.SortFields.Add Key:=rr.Columns(5), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
        .Sort.SortFields.Add Key:=rr.Columns(4), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
        .Sort.SortFields.Add Key:=rr.Columns(1), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .Sort.SortFields.Add Key:=rr.Columns(2), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .Sort.SortFields.Add Key:=rr.Columns(3), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        With .Sort
            .SetRange rr
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
    End With
    
    Set rOut = rOut.Cells(1, UBound(arr, 2) + 2)
    
End Sub

Private Sub InitResArray(res As Variant, nn As Long)
    ReDim res(1 To nn, 1 To 5)
    res(1, 1) = "Маршрут 1"
    res(1, 2) = "Маршрут 2"
    res(1, 3) = "Точек совпало"
    res(1, 4) = "Точек на маршруте 1"
    res(1, 5) = "Совпадение"
End Sub

Sub LongSort(rOutAreas As Range)
    
    Dim sh As Worksheet
    Set sh = rOutAreas.Parent
    
    Dim x As Integer
    
    Dim r1 As Range
    Dim r2 As Range
    Dim ar1 As Variant
    Dim ar2 As Variant
    Dim y As Long
    Dim bExit As Boolean
    Dim n2 As Long
    Dim y2 As Long
    'y = N / 2
    Dim N As Long
    N = NMAX - 1
    Dim rArea As Range
    Do
        
        For x = 1 To rOutAreas.Areas.Count
            Set rArea = rOutAreas.Areas(x)
            With sh.Sort
                .SortFields.Clear
                .SortFields.Add Key:=rArea.Columns(5), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
                .SetRange rArea: .Header = xlNo: .MatchCase = False: .Orientation = xlTopToBottom: .SortMethod = xlPinYin
                .Apply
            End With
        Next
        
        With sh
            bExit = True
            For x = 1 To rOutAreas.Areas.Count - 1
            'If Not IsEmpty(.Cells(1, x + 1).Value) Then
            If True Then
                y = 0
                On Error Resume Next
                y = WorksheetFunction.Match(rOutAreas.Areas(x + 1).Cells(1, 5).Value, rOutAreas.Areas(x).Columns(5), 1)
                On Error GoTo 0
                y = y + 1

                If y <= N Then
                    n2 = WorksheetFunction.CountA(rOutAreas.Areas(x + 1).Columns(5))
                    y2 = y + n2 - 1
                    If y2 > N Then y2 = N

                    'Set r1 = .Range(.Cells(y, x), .Cells(y2, x))
                    Set r1 = .Range(rOutAreas.Areas(x).Cells(y, 1), rOutAreas.Areas(x).Cells(y2, 5))
                    'Set r2 = .Cells(1, x + 1).Resize(r1.Rows.Count)
                    Set r2 = rOutAreas.Areas(x + 1).Cells(1, 1).Resize(r1.Rows.Count, 5)

                    ar1 = r1
                    ar2 = r2

                    r1 = ar2
                    Erase ar2
                    r2 = ar1
                    Erase ar1

                    bExit = False
                    'Exit For
                    If r1.Rows.Count <> N Then
                        With sh.Sort
                            .SortFields.Clear
                            .SortFields.Add Key:=rOutAreas.Areas(x + 1).Columns(5), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
                            .SetRange rOutAreas.Areas(x + 1): .Header = xlNo: .MatchCase = False: .Orientation = xlTopToBottom: .SortMethod = xlPinYin
                            .Apply
                        End With
                    End If
                End If
            End If
            Next
        End With
        
        If bExit Then Exit Do
    Loop
    
End Sub

Страницы: 1
Наверх