Alex_Piggy
Advanced Member | Редактировать | Профиль | Сообщение | ICQ | Цитировать | Сообщить модератору
Код:
Private Sub Worksheet_Change(ByVal Target As Range)
If Target <> "" And (Target.Row Mod 2) Then Call RecalcValuesRow(Target.Row)
End Sub
Sub RecalcAll()
For Z = 1 To ActiveSheet.Cells(1, 1).End(xlDown).Row Step 2
RecalcValuesRow (Z)
Next Z
End Sub
Sub RecalcValuesRow(Row As Integer)
Dim Dict As New Scripting.Dictionary
Set Dict = New Scripting.Dictionary
Dict.RemoveAll
With Range(Cells(Row, 1), Cells(Row, 1).End(xlToRight))
Arr = .Value
For i = LBound(Arr, 2) To UBound(Arr, 2) - 1
For j = i + 1 To UBound(Arr, 2)
If Arr(1, i) > Arr(1, j) Then
Temp = Arr(1, j)
Arr(1, j) = Arr(1, i)
Arr(1, i) = Temp
End If
Next j
Next i
Dict.Add 0, 0
For Each Data In Arr
If Not Dict.Exists(Data) Then Dict.Add Data, Dict.Count
Next
Set OutRange = .Offset(1, 0)
For i = 0 To .Count - 1
If Not OutRange.Cells(1, i + 1).Value = Dict.Item(.Cells(1, i + 1).Value) Then OutRange.Cells(1, i + 1).Value = Dict.Item(.Cells(1, i + 1).Value)
Next i
End With
Set Dict = Nothing
End Sub
|
|
