Сообщение от Elixi
(Сообщение 1863683)
Код:
Sub TEST()
' ДЛЯ ФАЙЛА КОТОРЫЙ ВЫ ПРИКРЕПИЛИ
' ЗАПУСКАЙТЕ ПРИ АКТИВНОМ ЛИСТЕ С ДАННЫМИ
Dim Data(), Korz(), Dict As Object
Dim Rw&, RwL&, Co&, Key$, Val$, KO&, PL&, PO&
Const RwF& = 2, CoF& = 1, CoL& = 5
Set Dict = CreateObject("Scripting.Dictionary")
' ДАННЫЕ В МАССИВ
RwL = Cells(Rows.Count, 3).End(xlUp).Row
Data = Range(Cells(RwF, CoF), Cells(RwL, CoL))
' СОРТИРОВКА ДАННЫХ
Data = BubbleSort(Data)
' ПОЛУЧЕНИЕ УНИКАЛЬНЫХ ДАННЫХ СТОЛБЦА КОРЗИНА
For Rw = LBound(Data, 1) To UBound(Data, 1)
If Not Dict.exists(Data(Rw, 5)) Then
Dict.Add Data(Rw, 5), 0
End If
Next Rw
' УНИКАЛЬНЫЕ ДАННЫЕ КОРЗИНА В МАССИВ
ReDim Korz(1 To Dict.Count)
For Rw = 0 To Dict.Count - 1
Korz(Rw + 1) = Dict.Keys()(Rw)
Next Rw
' ОЧИСТКА СЛОВАРЯ
Dict.RemoveAll
' НАПОЛНЕНИЕ СЛОВАРЯ ДАННЫМИ
For Rw = LBound(Data, 1) To UBound(Data, 1)
Key = Data(Rw, 5) & "," _
& Format(Data(Rw, 3), "00") & "," _
& Format(Data(Rw, 4), "00")
If Not Dict.exists(Key) Then
Val = Data(Rw, 1) & "," & Data(Rw, 2)
Dict.Add Key, Val
End If
Next Rw
' ДОПОЛНЕНИЕ СЛОВАРЯ НЕДОСТАЮЩИМИ ДАННЫМИ ПOРТ И ПЛАТА
' ВСЕ ЖЕЛАЕМЫЕ КOРЗИНЫ ВЗЯТЫ ИЗ СУЩЕСТВУЙУЩЕЙ ТАБЛИЦИ
For KO = LBound(Korz) To UBound(Korz)
For PL = 1 To 14
For PO = 1 To 48
Key = Korz(KO) & "," _
& Format(PL, "00") & "," _
& Format(PO, "00")
If Not Dict.exists(Key) Then
Val = ","
Dict.Add Key, Val
End If
Next PO
Next PL
Next KO
' ДАННЫЕ ИЗ СЛОВАРЯ В МАССИВ
ReDim Data(1 To Dict.Count, 1 To 5)
For Rw = 0 To Dict.Count - 1
Data(Rw + 1, 5) = Split(Dict.Keys()(Rw), ",")(0)
Data(Rw + 1, 3) = Split(Dict.Keys()(Rw), ",")(1)
Data(Rw + 1, 4) = Split(Dict.Keys()(Rw), ",")(2)
Data(Rw + 1, 1) = Split(Dict.Items()(Rw), ",")(0)
Data(Rw + 1, 2) = Split(Dict.Items()(Rw), ",")(1)
Next Rw
' СОРТИРОВКА ДАННЫХ
Data = BubbleSort(Data)
' ДАННЫЕ В НОВЫЙ ЛИСТ
ActiveSheet.Copy Before:=ActiveSheet
ActiveSheet.Name = Format(Date, "yyyy-mm-dd") & "_" & _
Format(Time, "hh-mm-ss")
ActiveSheet.UsedRange.Offset(1, 0).Clear
Cells(2, 1).Resize( _
UBound(Data, 1) - LBound(Data, 1) + 1, _
UBound(Data, 2) - LBound(Data, 2) + 1) = Data
' ОЧИСТКА
Dict.RemoveAll: ReDim Data(0): ReDim Korz(0)
End Sub
Function BubbleSort(Arr As Variant) As Variant
' Сортируем массив ...
' Если здесь чтo-тo тoрмoзит, тo этo именнo эта
' сoртирoвка. Для тестирoвки ее хватит. Хoтите
' пoбыстрее, сделайте себе другую.
Dim Check As Boolean, i%, j%, tmp As Variant
Do Until Check
Check = True
For i = LBound(Arr, 1) + 1 To UBound(Arr, 1) - 1
' ... по столбцам, по очереди (5, 3, 4):
If Arr(i, 5) > Arr(i + 1, 5) _
Or Arr(i, 5) = Arr(i + 1, 5) _
And Arr(i, 3) > Arr(i + 1, 3) _
Or Arr(i, 5) = Arr(i + 1, 5) _
And Arr(i, 3) = Arr(i + 1, 3) _
And Arr(i, 4) > Arr(i + 1, 4) _
Then
For j = LBound(Arr, 2) To UBound(Arr, 2)
tmp = Arr(i, j)
Arr(i, j) = Arr(i + 1, j)
Arr(i + 1, j) = tmp
Next
Check = False
End If
Next
Loop
BubbleSort = Arr
End Function
|
