Следующий код загрузит Range в массив. Затем он будет по очереди go проходить через каждую строку массива, сортировать значения в строке и сравнивать их с уже обработанными строками.
Если он новый, он добавляется в выходные данные и обрабатывается Ряды - если он уже существует, он игнорируется. Наконец, он выведет массив обратно в исходный диапазон
. Это немного сложнее, чем нужно, чтобы сохранить порядок элементов в первой строке для каждой комбинации - a более простым способом было бы отсортировать столбцы каждой строки по порядку, а затем просто использовать «Удалить дубликаты».
Код ArrayDimension набран из здесь , поэтому пожалуйста, подумайте о том, чтобы прогуляться, чтобы набрать Emeka Eya
Sub RemoveDuplicateRows(Target As Range, Optional Permutations As Boolean = False)
'Target: Range to remove duplicate rows from
'Permutations: If FALSE then ignore the order of elements in the row
Dim InputArray As Variant, ArrayPointer As Long
If Permutations Then
'This is just a normal RemoveDuplicates
ReDim InputArray(0 To (Target.Columns.Count - 1))
For ArrayPointer = 1 To Target.Columns.Count
InputArray(ArrayPointer - 1) = ArrayPointer
Next ArrayPointer
Target.RemoveDuplicates Columns:=InputArray, Header:=xlNo
Else
Dim RowArray As Variant, ArrayBinding As Long
Dim OutputArray As Variant, OutputRow As Variant
Dim ProcessedRows As Variant, CurrentRow As String
Dim TransferColumn As Long
InputArray = Target.Value
ArrayBinding = LBound(InputArray, 1)
OutputRow = ArrayBinding
'Empty array the same size as the input, and a 1D array the same height
ReDim OutputArray(LBound(InputArray, 1) To UBound(InputArray, 1), LBound(InputArray, 1) To UBound(InputArray, 1))
ReDim ProcessedRows(LBound(InputArray, 1) To UBound(InputArray, 1))
For ArrayPointer = ArrayBinding To UBound(InputArray, 1)
'Get 1D array containing just this specific row
RowArray = Application.Transpose(Application.Transpose(Application.Index(InputArray, ArrayPointer + 1 - ArrayBinding, 0)))
'Sort the Array and Flatten into a string for Searching
CurrentRow = SortArrayAndFlatten(RowArray)
'If the row is new, then add it
If UBound(Filter(ProcessedRows, CurrentRow)) < 0 Then
For TransferColumn = LBound(RowArray) To UBound(RowArray)
OutputArray(OutputRow, TransferColumn) = RowArray(TransferColumn)
Next TransferColumn
'Mark the row as already processed
ProcessedRows(OutputRow) = CurrentRow
OutputRow = OutputRow + 1
End If
Next ArrayPointer
Target.Clear
Target.Value = OutputArray
End If
End Sub
Private Function SortArrayAndFlatten(ByVal TargetArray As Variant) As String
'This will output a String of the Sorted Elements of the Array
If Not IsArray(TargetArray) Then Exit Function
'Only work on 1D arrays
If ArrayDimension(TargetArray) > 1 Then Exit Function
Dim OuterLoop As Long, InnerLoop As Long, StoppingPoint As Long, HoldingBucket As Variant, NoSwaps As Boolean
StoppingPoint = LBound(TargetArray) + 1
For OuterLoop = UBound(TargetArray) To StoppingPoint Step -1
NoSwaps = True
For InnerLoop = OuterLoop To StoppingPoint Step -1
If TargetArray(InnerLoop) > TargetArray(InnerLoop - 1) Then
'Swap the elements
HoldingBucket = TargetArray(InnerLoop)
TargetArray(InnerLoop) = TargetArray(InnerLoop - 1)
TargetArray(InnerLoop - 1) = HoldingBucket
NoSwaps = False
End If
Next InnerLoop
If NoSwaps Then Exit For
Next OuterLoop
SortArrayAndFlatten = Join(TargetArray, "|")
End Function
Function ArrayDimension(ByRef ArrayX As Variant) As Long
Dim i As Long, a As String, arDim As Long
On Error Resume Next
i = 0
Do
a = CStr(ArrayX(0, i))
If Err.Number > 0 Then
arDim = i
On Error GoTo 0
Exit Do
Else
i = i + 1
End If
Loop
If arDim = 0 Then arDim = 1
ArrayDimension = arDim
End Function