VBA Yearly Extract

[hobbiton73]

Hi, I wonder whether someone may be able to help me please.

I made a post here http://www.excelforum.com/excel-prog...-headings.html in respect of a problem I was encountering in adapting existing code.

I was very fortunate in receiving two possible solutions, with which I chose the one kindly provided by @Leith Ross.

As you will see from the link above, in particular message #13, that I've come across a problem which I've tried to engage with the author of the code, but sadly been unable to do.

I've noticed that in the case of where there is a row of data on the "All Data" sheet with a date in column J prior to my first column on the "Desired Output" sheet i.e. "April 14", although the value is correctly not paste to this sheet, the "Description", column I on the "All Data" Sheet is still shown in column B on the "Desired Output" sheet, thus creating a blank row.

As you also see I have tried over the last couple of days to find a solution, my knowledge has let me down.

I just wondered whether someone could possibly look at this and offer some guidance on how I may overcome the problem, or indeed, if you feel that there is a better solution offer guidance on how I can overcome my original problem.

I've uploaded the file here: https://www.dropbox.com/s/jfpcepzxzb...-submitted.xls

Many thanks and kind regards

Chris

[Bob Phillips]

Does this do it?

Sub YearlyExtract()
    
    Dim AFTE As Single
    Dim BlnProjExists As Boolean
    Dim ColDates As New Collection
    Dim DeO As Worksheet
    Dim EH As Worksheet
    Dim Flex As String
    Dim i As Long
    Dim IND As Worksheet
    Dim j As Long
    Dim JRole As String
    Dim LastRow As Long
    Dim m As Long
    Dim OVH As Worksheet
    Dim PCode As String
    Dim PDate As Date
    Dim PLOB As String
    Dim PRO As Worksheet
    Dim Project As String
    Dim RLOB As String
    Dim RngDates As Range
    Dim Task As String
    
    Application.ScreenUpdating = False
    
    Const StartRow As Long = 8
    Set DeO = Sheets("Desired Output")
    
    For i = 4 To DeO.Cells(StartRow - 1, Columns.Count).End(xlToLeft).Column
        m = m + 1
        ColDates.Add m, DeO.Cells(StartRow - 1, i).Text
    Next i
    
    With Sheets("All Data").Range("F7")
        For i = 1 To .CurrentRegion.Rows.Count - 1
            PLOB = .Offset(i, -4) ' Column B
            RLOB = .Offset(i, -3) ' Column C
            JRole = .Offset(i, -1) ' Column E
            Project = .Offset(i, 0) ' Column F
            Task = .Offset(i, 3) ' Column I
            PDate = .Offset(i, 4) ' Column J
            AFTE = .Offset(i, 8) ' Column N
            Flex = .Offset(i, 9) ' Column O
            
            If InStr(.Offset(i, 0), "TM - DIR") > 0 And InStr(.Offset(i, -1), "BAS") = 0 And _
                RLOB = "C&R" And Flex = "Yes" And AFTE > 0 And _
                .Offset(i, 4).Value >= Application.Min(DeO.Rows(7)) Then
                RLOB = .Offset(i, -3)
                JRole = .Offset(i, -1)
                Task = .Offset(i, 3)
                
                With DeO.Range("B7")
                    If .CurrentRegion.Rows.Count = 1 Then
                        .Offset(1, 0) = Task
                        .Offset(1, 1) = RLOB
                        j = 1
                    Else
                        BlnProjExists = False
                        For j = 1 To .CurrentRegion.Rows.Count - 1
                            If .Offset(j, 0) = Task And .Offset(j, 1) = RLOB Then
                                BlnProjExists = True
                                Exit For
                            End If
                            Next j
                            If BlnProjExists = False Then
                                .Offset(j, 0) = Task
                                .Offset(j, 1) = RLOB
                            End If
                    End If
                    
                    On Error Resume Next
                        m = ColDates(Format(PDate, "mmm yy"))
                        If Err = 0 Then .Offset(j, m + 1) = .Offset(j, m + 1) + AFTE
                    On Error GoTo 0
                End With
            End If
        Next i
    End With
End Sub

[hobbiton73]

Hi @xld, thank you very much, once again to take the time to help me out with this.

I don't really know what to say because the code works brilliantly and returns the correct results, thank you so much.

You know me of old, and I just wondered whether it may be possible for you to include some comments in the code please.

Once again sincere thanks and kind regards

Chris

[Bob Phillips]

It's not my code, I am not going to comment someone else's code. All ll I did was add an extra test within the IF of

And _ 
            .Offset(i, 4).Value >= Application.Min(DeO.Rows(7))

which just checks if the date in the current row, as defined by the variable i, is within the range of dates on the destination sheet, which is row 7.

[hobbiton73]

Hi @xld, I completely understand, how stupid of me to ask.

Many thanks and kind regards.

Chris

[Bob Phillips]

Hi @xld, I completely understand, how stupid of me to ask.

Chris, didn't mean to appear sharp. I rarely comment my own code, life is too short to comment someone else's

[hobbiton73]

Hi @xld, no that's absolutely no problem at all.

All the very best and take care.

Chris