Hi

I'm still not 100% sure that I've got it, but please try the following (& as
always, pls save before running any macro).

In brief what I've done is added a column in Sheet1 which keeps track of
whether the information has been transferred to Sheet2 or not.

You'll need to set the MyCol1, MyCol2, MyCol3, MyRow1, MyRow2 parameters in
the macro (there are comments there to help you do that).  MyCol3 will simply
be the column number of the first free column you have in Sheet1.  When
entering data simply leave this blank.  The macro will change it to TRUE when
it's copied that data across to Sheet2

I recommend stepping through the macro (with F8) to get a feel for what it's
doing.

Sub MyTransfer()

Dim MySh1 As Worksheet
Dim MySh2 As Worksheet
Dim MyCol1 As Integer
Dim MyCol2 As Integer
Dim MyCol3 As Integer

Set MySh1 = Sheets("Sheet1")
Set MySh2 = Sheets("Sheet2")
MyCol1 = 1 'column in Sheet1 where description is
MyCol2 = 2 'column in Sheet1 where allocation name is
MyCol3 = 3 'extra column in Sheet1 to keep track of what information has
been transferred to Sheet2
MyRow1 = 4 'row in Sheet1 where data starts
MyRow2 = 3 'row in Sheet2 where allocation headings are

'Run a loop through all the rows of sheet1
Do While MySh1.Cells(MyRow1, MyCol2) <> ""

'Check if data has already been transferred to sheet2
If Not MySh1.Cells(MyRow1, MyCol3) Then

'Check if Allocation name has already been used
MyAllName = MySh1.Cells(MyRow1, MyCol2)
Set MyAll = MySh2.Range("a1:iv1").Offset(MyRow2 - 1, 0).Find(MyAllName)
If MyAll Is Nothing Then
j = 1
Do Until MySh2.Cells(MyRow2, j) = ""
j = j + 1
If j > 255 Then
MsgBox "No more columns for allocations!"
Exit Sub
End If
Loop
MySh2.Cells(MyRow2, j) = MySh1.Cells(MyRow1, MyCol2)
i = MyRow2 + 1
Else
j = MyAll.Column
i = MyRow2 + 1
Do Until MySh2.Cells(i, j) = ""
i = i + 1
If i > 50000 Then
MsgBox "No more rows for allocation called " & MySh1.Cells(MyRow1, MyCol2)
Exit Sub
End If
Loop
End If
MySh2.Cells(i, j) = MySh1.Cells(MyRow1, MyCol1)
MySh1.Cells(MyRow1, MyCol3) = True

End If
MyRow1 = MyRow1 + 1

Loop

End Sub

I hope this helps