VBA: Help with conitional formating based on date/time

[mikesoll]

I inherited an Excel 2010 workbook that is utilized to import in another excel data feed that is extracted from online source daily. Once imported this .xlsm workbook does several things, custom columns, several sorts, conditional formatting, etc. It currently highlights all rows that have a CreatedDate of the current date. I need to modify this to evaluated the CreatedDate and highlight all rows in the last 24 hours as opposed to just the current date. I am struggling to find where I need to modify this code which is listed below. Additionally, to address a sorting problem, the initial creator of this strips the time of the CreateDate field upon import. The code below refers to the specific section of the macro that performs the highlighting of rows..

Public Sub highlightFields()
Dim finalrow, finalcol, x As Long
Dim cd, election, elec_dd, proj_type As String
finalcol = Cells.Find("*", searchorder:=xlByColumns, searchdirection:=xlPrevious).Column
finalrow = Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
For x = 1 To finalcol
    Select Case Trim(Cells(2, x).Text)
            Case "Election Due Date"
                elec_dd = MyColumnLetter(x * 1)
            Case "Created Date"
                 cd = MyColumnLetter(x * 1)
            Case "Election"
                election = MyColumnLetter(x * 1)
            Case "Project Type"
                proj_type = MyColumnLetter(x * 1)
    End Select
Next
For x = 3 To finalrow
            
            
            If DateDiff("d", Date, Range(elec_dd & x).Value) <= 7 Then
            With Range(elec_dd & x).Font
                .Bold = True
                .Color = -16776961
                .TintAndShade = 0
            End With
        End If
If CStr(Range(cd & x).Value) = CStr(Date) Then
            If Trim(Range(election & x).Value) <> "" Then
            With Range(election & x).Font
                .Bold = True
                .Color = -16776961
                .TintAndShade = 0
            End With
            End If
        
            With Range("A" & x & ":" & MyColumnLetter(finalcol * 1) & x).Interior
                .Pattern = xlSolid
                .PatternColorIndex = xlAutomatic
                .ThemeColor = xlThemeColorAccent3
                .TintAndShade = 0.799981688894314
                .PatternTintAndShade = 0
            End With
        
    End If
    If Range(proj_type & x) = "Initial Well" Then
                With Range(elec_dd & x).Font
                    .ColorIndex = xlAutomatic
                    .TintAndShade = 0
                End With
    End If
Next
End Sub

 

[Jeffrey Smith]

Oh dummy me, I forgot to test the number of days difference. See how this works.

Change this line:

If 1440 - Cellmins + Nowmins < 1440 Then

To this line:

If int(Now()) - int(CellDate) < 2 and 1440 - Cellmins + Nowmins < 1440 Then

 

[mikesoll]

That did the trick! I imported the new data and it highlighted all records up within the last 24 from what it looks like is my local time so all records with a date/time of 9/4/2013 10:50 AM or newer were highlighted. However something strange happens, on this import I have 5 records with today's date of 9/5/2013 and it doesn't highlight any of those. Thoughts?

 

[mikesoll]

As I continue to import new data sheets to test I can see it is highlighting back exactly 24 hours from my system time so records from 9/4/2013 continue to drop off as the time progresses however it still will not pick up(highlight) any records with a date value of the current date 9/5/2013 regardless of the time.

 

[Jeffrey Smith]

I am going to have to stop responding to so many questions so I can concentrate a little more.

Try this:

Public Sub highlightFields()
  Dim finalrow, finalcol, X As Long
  Dim cd, election, elec_dd, proj_type As String
  
  Dim Nowmins As Long
  Dim Cellmins As Long
  Dim CellDate As Date
[COLOR=#ff0000]  Dim NumDays As Integer[/COLOR]
  
  finalcol = Cells.Find("*", searchorder:=xlByColumns, searchdirection:=xlPrevious).Column
  finalrow = Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
  For X = 1 To finalcol
    Select Case Trim(Cells(2, X).Text)
      Case "Election Due Date"
          elec_dd = MyColumnLetter(X * 1)
      Case "Created Date"
           cd = MyColumnLetter(X * 1)
      Case "Election"
          election = MyColumnLetter(X * 1)
      Case "Project Type"
          proj_type = MyColumnLetter(X * 1)
    End Select
  Next
  For X = 3 To finalrow
    If DateDiff("d", Date, Range(elec_dd & X).Value) <= 7 Then
      With Range(elec_dd & X).Font
          .Bold = True
          .Color = -16776961
          .TintAndShade = 0
      End With
    End If
    
    CellDate = Range(cd & X).Value
    Nowmins = Minute(Now()) + Hour(Now()) * 60
    Cellmins = Minute(CellDate) + Hour(CellDate) * 60
[COLOR=#ff0000]    NumDays = Int(Now()) - Int(CellDate)[/COLOR]
[COLOR=#ff0000]    If (NumDays = 1 And 1440 - Cellmins + Nowmins < 1440) Or (NumDays = 0) Then[/COLOR]
      If Trim(Range(election & X).Value) <> "" Then
        With Range(election & X).Font
            .Bold = True
            .Color = -16776961
            .TintAndShade = 0
        End With
      End If
    
      With Range("A" & X & ":" & MyColumnLetter(finalcol * 1) & X).Interior
          .Pattern = xlSolid
          .PatternColorIndex = xlAutomatic
          .ThemeColor = xlThemeColorAccent3
          .TintAndShade = 0.799981688894314
          .PatternTintAndShade = 0
      End With
          
    End If
    If Range(proj_type & X) = "Initial Well" Then
      With Range(elec_dd & X).Font
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
      End With
    End If
  Next
End Sub

Jeff

 

[mikesoll]

Works great now based on the data I have available everything is working as it should. I can't thank you enough for giving up your time to assist me with this and I apologize if I had to many questions. One last thing if I may ask, going back to the beginning of this thread we had to add back in the time value to the "Created Date" since it was being stripped off. As I mentioned earlier I inherited this macro and I'm being told the time was striped off originally due to a sorting problem. Once the data sheet is imported I cannot tell what it is sorted by exactly however I would like it to be the "Created Date" that we have been addressing so once completed all these highlighted records for the past 24 hours are at the top. Right now I have to manually sort on that column after the import is completed. Thoughts? and again thank you very much!

 

[Jeffrey Smith]

Based on the code where it was changing the date, column AU seems to be the createdate column. This code is the only place inthe code you posted that shows a sorting based on the column AU:

If electionsTitle = "Elections Pending" Then
        ActiveWorkbook.Worksheets("Proposals").Sort.SortFields.Clear
        'created date
        ActiveWorkbook.Worksheets("Proposals").Sort.SortFields.Add Key:=Range( _
            "AU2:AU" & finalrow), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:= _
            xlSortNormal
        'election due date
        ActiveWorkbook.Worksheets("Proposals").Sort.SortFields.Add Key:=Range( _
            "D2:D" & finalrow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
            xlSortNormal
        'legal description
        ActiveWorkbook.Worksheets("Proposals").Sort.SortFields.Add Key:=Range( _
            "S2:S" & finalrow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
            xlSortNormal
        'state
        ActiveWorkbook.Worksheets("Proposals").Sort.SortFields.Add Key:=Range( _
            "U2:U" & finalrow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
            xlSortNormal
        'county
        ActiveWorkbook.Worksheets("Proposals").Sort.SortFields.Add Key:=Range( _
            "T2:T" & finalrow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
            xlSortNormal
        With ActiveWorkbook.Worksheets("Proposals").Sort
            .SetRange Range("A1:BB" & finalrow)
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With

Now, this code is sorting by the primary field of Create Date (Column AU). In my opinion, leaving the time in shouldn't interfere with proper sorting. The code above is sorting the create date in a Descending manner. Excel would put the most recent date and time at the top. I would have to have the workbook, see it run, debug the code as it's happening to decipher where to alter the code so it properly sorted the dates right. If you want to send me a copy, I could take a look. Message me with your email address and I will respond.

Jeff