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
|