Sub Extract()
        Dim i As Long, j As Long, m As Long
        Dim strProject As String
        Dim RDate As Date
        Dim RVal As Single
        Dim BlnProjExists As Boolean
        With Sheets("Enhancements").Range("B3")
        For i = 1 To .CurrentRegion.Rows.Count - 1
            For j = 0 To 13
                .Offset(i, j) = ""
            Next j
        Next i
    End With
    With Sheets("AllData").Range("E3")
        For i = 1 To .CurrentRegion.Rows.Count - 1
        strProject = .Offset(i, 0)
        RDate = .Offset(i, 3)
        RVal = .Offset(i, 4)
         If InStr(.Offset(i, 0), "Enhancements") > 0 Then
                strProject = .Offset(i, 0)
            ElseIf InStr(.Offset(i, 0), "OVH") > 0 And RVal > 0 Then
                strProject = .Offset(i, -1)
            Else
                GoTo NextLoop
            End If
     
            With Sheets("Enhancements").Range("B3")
                If .CurrentRegion.Rows.Count = 1 Then
                    .Offset(1, 0) = strProject
                    j = 1
                Else
                    BlnProjExists = False
                    For j = 1 To .CurrentRegion.Rows.Count - 1
                        If .Offset(j, 0) = strProject Then
                            BlnProjExists = True
                            Exit For
                        End If
                    Next j
                    If BlnProjExists = False Then
     .Offset(j, 0) = strProject
                    End If
                End If
                Select Case Format(RDate, "mmm yy")
                    Case "Apr 13"
                        m = 1
                    Case "May 13"
                        m = 2
                    Case "Jun 13"
                        m = 3
                    Case "Jul 13"
                        m = 4
                    Case "Aug 13"
                        m = 5
                    Case "Sep 13"
                        m = 6
                    Case "Oct 13"
                        m = 7
                    Case "Nov 13"
                        m = 8
                    Case "Dec 13"
                        m = 9
                    Case "Jan 14"
                        m = 10
                    Case "Feb 14"
                        m = 11
                    Case "Mar 14"
                        m = 12
                End Select
                .Offset(j, m) = .Offset(j, m) + RVal
            End With
    NextLoop:
        Next i
    End With
    End Sub
           
    If InStr(.Offset(i, 0), "Enhancements") > 0 Then
                    strProject = .Offset(i, 0)
                ElseIf InStr(.Offset(i, 0), "OVH") > 0 And RVal > 0 Then
                    strProject = .Offset(i, -1)
                Else
                    GoTo NextLoop
                End If
     
                With Sheets("Enhancements").Range("B3")
                    If .CurrentRegion.Rows.Count = 1 Then
                        .Offset(1, 0) = strProject
                        j = 1
                    Else
           
    Sub HTH()
        Dim rLookup As Range, rFound As Range
        Dim lLastRow As Long, lRow As Long
        Dim lMonthIndex As Long, lProjectIndex As Long
        Dim vData As Variant, vMonths As Variant
        Dim iLoop As Integer
        Dim vbDict As Object
     
        With Worksheets("AllData")
            Set rLookup = .Range("E3", .Cells(Rows.Count, "E").End(xlUp))
            Set rFound = .Range("E3")
        End With
     
        Set vbDict = CreateObject("Scripting.Dictionary")
        vMonths = Array(4, 5, 6, 7, 8, 9, 10, 11, 12, 1, 2, 3)
     
        For iLoop = 0 To 1
            lRow = 0: lLastRow = 3
            vbDict.RemoveAll: ReDim vData(rLookup.Count, 13)
            Do
                Set rFound = Worksheets("AllData").Cells.Find(Array("Enhancements", "OVH")(iLoop), _
                    rFound, , , xlByRows, xlNext, False)
                If rFound Is Nothing Then Exit Do
                If rFound.Row <= lLastRow Then Exit Do
                lMonthIndex = WorksheetFunction.Match(Month(CDate(rFound.Offset(, 4).Value)), vMonths, False)
                If vbDict.exists(rFound.Offset(, -iLoop).Value) Then
                    lProjectIndex = vbDict.Item(rFound.Value)
                    vData(lProjectIndex, lMonthIndex) = _
                    vData(lProjectIndex, lMonthIndex) + rFound.Offset(, 4).Value
                Else
                    vbDict.Add rFound.Offset(, -iLoop).Value, lRow
                    vData(lRow, 0) = rFound.Offset(, -iLoop).Value
                    vData(lRow, lMonthIndex) = rFound.Offset(, 4).Value
                    lRow = lRow + 1
                End If
                lLastRow = rFound.Row
            Loop
            If iLoop = 0 Then
                With Worksheets("Enhancements")
                    .Range("B4:O" & Rows.Count).ClearContents
                    .Range("B4").Resize(vbDict.Count + 1, 13).Value = vData
                End With
            Else
                With Worksheets("Overheads")
                    .Range("B4:O" & Rows.Count).ClearContents
                    .Range("B4").Resize(vbDict.Count + 1, 13).Value = vData
                End With
            End If
        Next iLoop
     
    End Sub
           
    Sub HTH()
        Dim rLookup As Range, rFound As Range
        Dim lLastRow As Long, lRow As Long
        Dim lMonthIndex As Long, lProjectIndex As Long
        Dim vData As Variant, vMonths As Variant
        Dim iLoop As Integer
        Dim vbDict As Object
     
        '// Get the projects range to loop through
        With Worksheets("AllData")
            Set rLookup = .Range("E3", .Cells(Rows.Count, "E").End(xlUp))
            Set rFound = .Range("E3")
        End With
     
        '// Use a latebinded dictionary to store the project names.
        Set vbDict = CreateObject("Scripting.Dictionary")
        '// Create an array of the months to get the correct columns.  Instead of your select case method
        vMonths = Array(4, 5, 6, 7, 8, 9, 10, 11, 12, 1, 2, 3)
     
        '// Loop through both search requirements
        For iLoop = 0 To 1
            '// Set the counters - lLastRow is used to make sure the loop is not never ending.
            lRow = 0: lLastRow = 3
            '// Clear the dictionary and create the projects array.
            vbDict.RemoveAll: ReDim vData(rLookup.Count, 13)
            Do
                '// Search using the criteria requried
                Set rFound = Worksheets("AllData").Cells.Find(Array("Enhancements", "OVH")(iLoop), _
                    rFound, , , xlByRows, xlNext, False)
                '//  Make sure something was found and its not a repeat.
                If rFound Is Nothing Then Exit Do
                If rFound.Row <= lLastRow Then Exit Do
                '//  Get the correct month column using our months array and the project date.
                lMonthIndex = WorksheetFunction.Match(Month(CDate(rFound.Offset(, 4).Value)), vMonths, False)
                '// Check if the project exists.
                If vbDict.exists(rFound.Offset(, -iLoop).Value) Then
                    '// Yes it exists so add the actuals to the correct project/month.
                    lProjectIndex = vbDict.Item(rFound.Value)
                    vData(lProjectIndex, lMonthIndex) = _
                    vData(lProjectIndex, lMonthIndex) + rFound.Offset(, 4).Value
                Else
                    '// No it doesnt exist, create it and then add the actuals to the correct project/month
                    vbDict.Add rFound.Offset(, -iLoop).Value, lRow
                    vData(lRow, 0) = rFound.Offset(, -iLoop).Value
                    vData(lRow, lMonthIndex) = rFound.Offset(, 4).Value
                    '// Increase the project count.
                    lRow = lRow + 1
                End If
                '// Set the last row = the last found row to ensure we dont repeat the search.
                lLastRow = rFound.Row
            Loop
            If iLoop = 0 Then
                '// Clear the enhancements sheet and populate the cells from the array
                With Worksheets("Enhancements")
                    .Range("B4:O" & Rows.Count).ClearContents
                    .Range("B4").Resize(vbDict.Count + 1, 13).Value = vData
                End With
            Else
                '// Clear the overheads sheet and populate the cells from the array
                With Worksheets("Overheads")
                    .Range("B4:O" & Rows.Count).ClearContents
                    .Range("B4").Resize(vbDict.Count + 1, 13).Value = vData
                End With
            End If
        Next iLoop
     
    End Sub
           
    Sub Extract()
     
        Dim cllProjects As Collection
        Dim wsData As Worksheet
        Dim wsEnha As Worksheet
        Dim wsOver As Worksheet
        Dim rngFind As Range
        Dim rngFound As Range
        Dim rngProject As Range
        Dim arrProjects() As Variant
        Dim varProjectType As Variant
        Dim ProjectIndex As Long
        Dim cIndex As Long
        Dim dRVal As Double
        Dim dRDate As Double
        Dim strFirst As String
        Dim strProjectFirst As String
        Dim strProject As String
     
        Set wsData = Sheets("AllData")
        Set wsEnha = Sheets("Enhancements")
        Set wsOver = Sheets("Overheads")
     
        wsEnha.Range("B4:O" & Rows.Count).ClearContents
        wsOver.Range("B4:O" & Rows.Count).ClearContents
     
        With wsData.Range("E4", wsData.Cells(Rows.Count, "E").End(xlUp))
            If .Row < 4 Then Exit Sub   'No data
            On Error Resume Next
            For Each varProjectType In Array("Enhancements", "OVH")
                Set cllProjects = New Collection
                ProjectIndex = 0
                ReDim arrProjects(1 To WorksheetFunction.CountIf(.Cells, "*" & varProjectType & "*"), 1 To 14)
                Set rngFound = .Find(varProjectType, .Cells(.Cells.Count), xlValues, xlPart)
                If Not rngFound Is Nothing Then
                    strFirst = rngFound.Address
                    Do
                        strProject = vbNullString
                        dRDate = wsData.Cells(rngFound.Row, "H").Value2
                        dRVal = wsData.Cells(rngFound.Row, "I").Value2
     
                        If varProjectType = "OVH" And dRVal > 0 Then
                            strProject = wsData.Cells(rngFound.Row, "D").Text
                            Set rngFind = Intersect(.EntireRow, wsData.Columns("D"))
                        ElseIf varProjectType = "Enhancements" Then
                            strProject = wsData.Cells(rngFound.Row, "E").Text
                            Set rngFind = .Cells
                        End If
     
                        If Len(strProject) > 0 Then
                            cllProjects.Add LCase(strProject), LCase(strProject)
                            If cllProjects.Count > ProjectIndex Then
                                ProjectIndex = cllProjects.Count
                                arrProjects(ProjectIndex, 1) = strProject
                                Set rngProject = Intersect(rngFound.EntireRow, Columns(rngFind.Column))
                                strProjectFirst = rngProject.Address
                                Do
                                    If LCase(rngProject.Text) = LCase(strProject) Then
                                        dRDate = wsData.Cells(rngProject.Row, "H").Value2
                                        dRVal = wsData.Cells(rngProject.Row, "I").Value2
                                        cIndex = Month(dRDate) - 2 + (Year(dRDate) - 2013) * 12
                                        arrProjects(ProjectIndex, cIndex) = arrProjects(ProjectIndex, cIndex) + dRVal
                                    End If
                                    Set rngProject = rngFind.Find(arrProjects(ProjectIndex, 1), rngProject, xlValues, xlPart)
                                Loop While rngProject.Address <> strProjectFirst
                            End If
                        End If
                        Set rngFound = .Find(varProjectType, rngFound, xlValues, xlPart)
                    Loop While rngFound.Address <> strFirst
                End If
     
                If cllProjects.Count > 0 Then
                    Select Case varProjectType
                        Case "Enhancements":    wsEnha.Range("B4").Resize(cllProjects.Count, UBound(arrProjects, 2)).Value = arrProjects
                        Case "OVH":             wsOver.Range("B4").Resize(cllProjects.Count, UBound(arrProjects, 2)).Value = arrProjects
                    End Select
                    Set cllProjects = Nothing
                End If
     
            Next varProjectType
            On Error GoTo 0
        End With
     
        Set cllProjects = Nothing
        Set wsData = Nothing
        Set wsEnha = Nothing
        Set wsOver = Nothing
        Set rngFound = Nothing
        Set rngProject = Nothing
        Erase arrProjects
     
    End Sub