Если есть только несколько имен, вы можете сделать следующее с клавиатуры:
- Сортировать список, если еще не отсортирован.
- Выберите числа против имени.
- Перейти к столбцу C первого ряда для имени
- Выберите «Редактировать», «Вставить специальные», «Транспонировать значения», «ОК».
- Удалить все, кроме первой строки имени
- Повторите шаги с 2 по 5 для всех остальных имен
- Удалить столбец B.
Если у вас много имен, вам понадобится решение VBA:
Option Explicit
Sub TransposeColB()
Dim ColCrntNext As Integer ' The next cell on the current row
Dim ColNextLast As Integer ' The last cell on the next row
Dim Offset As Integer ' Offset from first number on row to last
Dim RowCrnt As Integer ' Current row
With Sheets("Sheet1") ' !!!! Replace "Sheet1" with name of your sheet !!!!
' Sort entire sheet in case a partial tranpose has occurred.
.Cells.Sort Key1:=.Range("A1"), Order1:=xlAscending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
RowCrnt = 1
' Identify first blank cell on row. This ensures nothing is overwritten.
ColCrntNext = .Cells(RowCrnt, Columns.Count).End(xlToLeft).Column + 1
Do While True
' Check name on next row
Select Case .Cells(RowCrnt + 1, "a").Value
Case ""
' The next row has no name. The transpose is complete.
Exit Do
Case .Cells(RowCrnt, "a").Value
' The next row has the same name as the current row. Move its
' numbers to the current row.
' Find last used column on the next row
ColNextLast = .Cells(RowCrnt + 1, _
Columns.Count).End(xlToLeft).Column
Offset = ColNextLast - 2 ' Offset from first number to last.
' Normally zero.
' Move numbers from next row to current
.Range(.Cells(RowCrnt, ColCrntNext), _
.Cells(RowCrnt, ColCrntNext + Offset)).Value = _
.Range(.Cells(RowCrnt + 1, 2), _
.Cells(RowCrnt + 1, 2 + Offset)).Value
.Rows(RowCrnt + 1).EntireRow.Delete ' Delete next row
ColCrntNext = ColCrntNext + Offset + 1 ' Advance to first blank cell
Case Else
' The next row is for a new name
RowCrnt = RowCrnt + 1
' Identify first blank cell on row. This ensures
' nothing is overwritten.
ColCrntNext = .Cells(RowCrnt, _
Columns.Count).End(xlToLeft).Column + 1
End Select
Loop
End With
End Sub