ЯКЩО ваш список буде відсортований у стовпці А, тоді цей метод дасть вам те, що ви хочете.
Скопіюйте список у стовпчик А в інший стовпчик.
Потім використовуйте Видалити дублікати, щоб отримати унікальний список:
Потім у першу клітинку поруч із першим елементом ставлять:
=IF(COLUMN(A:A)>COUNTIF($A:$A,$E1),"",INDEX($B:$B,MATCH($E1,$A:$A,0)+COLUMN(A:A)-1))
Потім скопіюйте стільки стовпців, скільки найбільша кількість елементів. Потім скопіюйте донизу списку.
Потім скопіюйте та вставте значення в новий аркуш або на себе.
Якщо ви хочете зробити це на місці; Я написав цей код для іншого сайту, який залишиться безіменним. Це зробить саме те, що ви хочете, досить швидко на місці:
Sub FOOO()
Dim inArr() As Variant
Dim outArr() As Variant
Dim ws As Worksheet
Dim cntrw As Long
Dim cntclm As Long
Dim i As Long
Dim j As Long
Dim k As Long
Dim rng As Range
Set ws = ActiveSheet
With ws
Set rng = .Range("A1", .Cells(.Rows.Count, "A").End(xlUp))
'find the max number column that will be needed in the output
cntclm = ws.Evaluate("MAX(COUNTIF(" & rng.Address & "," & rng.Address & "))") + 1
'find the number of rows that will be needed in the output.
cntrw = ws.Evaluate("SUM(1/COUNTIF(" & rng.Address & "," & rng.Address & "))")
'put the existing data into an an array
inArr = rng.Resize(, 2).Value
'resize output array to the extents needed
ReDim outArr(1 To cntrw, 1 To cntclm)
'put the first value in the first spot in the output
outArr(1, 1) = inArr(1, 1)
outArr(1, 2) = inArr(1, 2)
'these are counters to keep track of which slot the data should go.
j = 3
k = 1
'loop through the existing data rows
For i = 2 To UBound(inArr, 1)
'test whether the data in A has changed or not.
If inArr(i, 1) = inArr(i - 1, 1) Then
'if not put the value in B in the next slot and iterate to the next column
outArr(k, j) = inArr(i, 2)
j = j + 1
Else
'if change start a new line in the outarr and fill the first two slots
k = k + 1
j = 3
outArr(k, 1) = inArr(i, 1)
outArr(k, 2) = inArr(i, 2)
End If
Next i
'remove old data
.Range("A:B").Clear
'place new data in its place.
.Range("A1").Resize(UBound(outArr, 1), UBound(outArr, 2)).Value = outArr
End With
End Sub
Перед:
Після:
ПРИМІТКА: обидва методи вимагають сортування стовпця А.