This first chunk of code is going through and rearranging things for you. The other important thing it does is only sends one column from your selected range to the function. Some important things to remember are you may need to write the search criteria if you key word for "month" is not in the same spot in the text, the word offer is not by itself with no spaces in the following row. Another point of note, is this is treating everything as is. That means if the source cell was text, then the destination cell will be text. To convert from date as text to date as Excel serial that is a separate issue and there are plenty of ways to achieve that as well.
Option Explicit
Sub SortOffer(OfferList As Range)
Dim CounterX As Long, CounterY As Long, jCounter As Long, icounter As Long, MonthCount As Long, UniqueOffers As Long
Dim inlist As Boolean
Dim unsorted() As Variant
Dim sorted() As Variant
MonthCount = WorksheetFunction.CountIf(OfferList, "month*")
UniqueOffers = CountUnique(OfferList.Columns(1).Cells) - MonthCount - 1
ReDim sorted(1 To UniqueOffers + 1, 1 To MonthCount + 1) As Variant
unsorted = OfferList
CounterX = 1
jCounter = 1
sorted(1, 1) = "offer"
For CounterY = LBound(unsorted, 1) To UBound(unsorted, 1)
If Left(unsorted(CounterY, 1), 5) = "month" Then
CounterX = CounterX + 1
sorted(1, CounterX) = Right(unsorted(CounterY, 1), Len(unsorted(CounterY, 1)) - 6)
Else
inlist = False
For icounter = 2 To jCounter
If unsorted(CounterY, 1) = sorted(icounter, 1) Then
sorted(icounter, CounterX) = unsorted(CounterY, 2)
inlist = True
End If
Next icounter
If Not inlist And unsorted(CounterY, 1) <> "offer" And unsorted(CounterY, 1) <> "" Then
jCounter = jCounter + 1
sorted(jCounter, 1) = unsorted(CounterY, 1)
sorted(jCounter, CounterX) = unsorted(CounterY, 2)
End If
End If
Next CounterY
Range("F1").Resize(UBound(sorted, 1), UBound(sorted, 2)).Value = sorted
End Sub
This next function counts the number of unique entries in a range and does not count spaces. I stumbled across this code on this web page. If you subtract the number of months from this count, you will know how many offers are in your table. This is important because it will tell you how to size your array(alt link) that you will later write back as your results
Function CountUnique(ByVal MyRange As Range) As Integer
Dim Cell As Range
Dim J As Integer
Dim iNumCells As Integer
Dim iUVals As Integer
Dim sUCells() As String
iNumCells = MyRange.Count
ReDim sUCells(iNumCells) As String
iUVals = 0
For Each Cell In MyRange
If Cell.Text > "" Then
For J = 1 To iUVals
If sUCells(J) = Cell.Text Then
Exit For
End If
Next J
If J > iUVals Then
iUVals = iUVals + 1
sUCells(iUVals) = Cell.Text
End If
End If
Next Cell
CountUnique = iUVals
End Function
Now just in case the links don't cover it, this answer which was a learning lesson for me was taught in various parts to me by @JNevill, @Ralph, @findwindow, @Gary'sStudent and @ScottCraner. Appologies if I missed someone. I am also sure any of these individuals could do it slicker and take less then 10 hours to write it 8).