Finding and Setting Columns

Hey Everyone,

I've got columns labelled using two seperate cells. I want to find these columns using a macro so that I can then copy and paste certain rows of information from these columns. The only problem is since the columns are labelled using two cells sometimes key words repeat. So I have tried to create a search and check. However when I try to paste data using methods I have used in the past it doesn't seem to work. I get Run Time Error '1004' Application-Defined or object defined error.

I know I've probably explained this poorly so I've attached a work book and the code below.

Thanks for help in advance

Sub DoubleColumn()

Dim AllocOil As Range
Dim Oil As String
Dim ColAllocOil As Long

Set AllocOil = Worksheets("Sheet1").Range("A5:Q8").Cells.Find(What:="Alloc", LookIn:=xlFormulas, LookAt:=xlWhole, _
                       SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, _
                       SearchFormat:=False)
For i = 1 To 10

If AllocOil.Offset(1, 0) = "oil" Then

ColAllocOil = AllocOil.Column
Exit For

Else
Set AllocOil = Worksheets("Sheet1").Range("A5:Q8").Cells.FindNext(After:=AllocOil)
End If

Next i

Worksheets("Sheet1").Cells(1, "A").Value = Worksheets("Sheet1").Cells(8, ColAllocOil).Value

End Sub