I have data as shown below in two columns and I need to arrange them horizontally in a row for each individual.

Baker   17                              
Baker   37                              
Baker   28                              
Baker   49                              
Baker   27                              
Baker   44                              
Baker   47                              
Baker   32                              
Baker   29                              
Boley   13                              
Boley   46                              
Boley   10                              
Boley   35                              
Boley   32                              
Boley   49                              
Boley   18                              
Boley   47                              
Boley   22                              

Baker   17  37  28  49  27  44  47  32  29
Boley   13  46  10  35  32  49  18  47  22

How can I do that?

  1. Make list of all unique entries from Column A. In this sample, it would be a matter of typing two names. With a larger data set you could copy that column to your target location and just use the Remove Duplicates tool to pare down the list.

  2. To the right of the first name in your new list (Mine starts at F1, so I have the following in G1), enter the following formula as an array formula by pressing Ctrl+Shift+Enter:


For reference, A1:A18 is your original list of Names, B1:B18 is their corresponding numbers, and F1 is the name "Baker" in your new table. Fill this over to the right as far as you like. Then, fill down to complete your table.

NOTE: If your original data does NOT start on Row 1, then use the following formula instead, where A1 is the top-left cell of your original data:


If there are only a few names, you could do the following from the keyboard:

  1. Sort the list, if not already sorted.
  2. Select the numbers against the first name.
  3. Move to Column C of the first row for the name
  4. Select Edit, Paste Special, Transpose Values, OK
  5. Delete all but the first row for the name
  6. Repeat steps 2 to 5 for all other names
  7. Delete column B.

If you have lots of names, you will need a VBA solution:

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, _
          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
  End With

End Sub

As someone who has been looking for an easy fix for this, specifically if the count for each is irregular, I came across this video which has finally done exactly what I need.


Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.