Sub Макрос1()
arr = Range("A2:AX" & Cells(Rows.Count, 1).End(xlUp).Row).Value
For n = 1 To UBound(arr)
arr(n, 50) = arr(n, 47) & arr(n, 49) & arr(n, 48)
Next
Sort_Array arr, 50
Set sd = CreateObject("Scripting.Dictionary")
For n = 1 To UBound(arr)
If Not sd.Exists(arr(n, 1)) Then Set sd(arr(n, 1)) = CreateObject("Scripting.Dictionary"): m = m + 1
If Not sd(arr(n, 1)).Exists(arr(n, 47) & "|" & arr(n, 49)) Then Set sd(arr(n, 1))(arr(n, 47) & "|" & arr(n, 49)) = CreateObject("Scripting.Dictionary")
If Not sd(arr(n, 1))(arr(n, 47) & "|" & arr(n, 49)).Exists(arr(n, 48)) Then Set sd(arr(n, 1))(arr(n, 47) & "|" & arr(n, 49))(arr(n, 48)) = CreateObject("Scripting.Dictionary")
If Not sd(arr(n, 1))(arr(n, 47) & "|" & arr(n, 49))(arr(n, 48)).Exists(arr(n, 4)) Then sd(arr(n, 1))(arr(n, 47) & "|" & arr(n, 49))(arr(n, 48)).Add arr(n, 4), arr(n, 4): m = m + 1
Next
ReDim arr_rez(1 To m, 1 To 5)
n = 1
For Each y In sd
arr_rez(n, 1) = y
n = n + 1
okr_zag = okr_zag & "|A" & n & ":E" & n
For Each y1 In sd(y)
k_max = 0
p = ""
For Each y2 In sd(y)(y1)
If p <> y2 Then p = y2: k = 0
For Each y3 In sd(y)(y1)(y2)
arr_rez(n + k, 1) = Split(y1, "|")(0)
arr_rez(n + k, 2) = Split(y1, "|")(1)
If y2 = "X" Then arr_rez(n + k, 3) = sd(y)(y1)(y2)(y3)
If y2 = "Y" Then arr_rez(n + k, 4) = sd(y)(y1)(y2)(y3)
If y2 = "Z" Then arr_rez(n + k, 5) = sd(y)(y1)(y2)(y3)
k = k + 1
Next
If k_max < k Then k_max = k
Next
okr = okr & "|A" & n + 1
n = n + k_max
okr = okr & ":E" & n
Next
Next
With Worksheets("Результат")
.Range("A2:E" & Cells(Rows.Count, 1).End(xlUp).Row).Clear ' = ""
.Range("A2").Resize(UBound(arr_rez), 5) = arr_rez
.Activate
arr_okr = Split(Mid(okr, 2), "|")
For Each y In arr_okr
If n = 1 Then
.Range(y).Interior.Color = 6737151
n = 0
Else
.Range(y).Interior.Color = 10092543
n = 1
End If
Next
arr_okr = Split(Mid(okr_zag, 2), "|")
For Each y In arr_okr
.Range(y).Interior.Color = 6724095
Next
End With
End Sub
Function Sort_Array(arr As Variant, n As Integer)
Dim i As Long, j As Long, temp As Variant
For i = LBound(arr, 1) To UBound(arr, 1) - 1
For j = i + 1 To UBound(arr, 1)
If arr(i, n) > arr(j, n) Then
For col = LBound(arr, 2) To UBound(arr, 2)
temp = arr(i, col)
arr(i, col) = arr(j, col)
arr(j, col) = temp
Next col
End If
Next j
Next i
Sort_Array = arr
End Function
|
