allocting to fixed headings:

Private Sub CommandButton1_Click()
Dim i As Integer, n As Integer

i = 3
Do Until IsEmpty(Cells(1, i))
For n = 2 To 23
If Cells(n, 1) = Cells(1, i) Then
Cells(n, i) = Cells(n, 2)
End If
Next n
i = i + 1
Loop

End Sub

2nd Exercise: Making the headings as well

Private Sub cmdAllocate_Click()
Dim rng As Range, i As Integer, c As Integer, j As Integer, found As Boolean, col As Integer
Set rng = Range("A2:a23")

c = 2
For i = 1 To rng.Count

rng.Cells(i).Select 'for single-stepping

found = False

For j = 2 To c 'across the existing headings
If Trim(rng.Cells(i)) = Trim(Cells(1, j)) Then ' ie if its there...
found = True '...remember its there
col = j 'and remember which column it was found in so that we can later put the amount beneath.
Exit For 'stop looking - we found it thanks
End If
Next j

If found = False Then 'ie it wasn't there
c = c + 1 'next cell across the heading row.
Cells(1, c).Value = Trim(rng.Cells(i).Value) 'post it up as a new heading at the end of the header row
col = c ' if its a new column remember the column number so wed can later the amount beneath.
End If

rng.Cells(i).Offset(0, col - 1) = rng.Cells(i).Offset(0, 1) 'put the amount in - in the same row.

Next i

End Sub