VBA: Help with conitional formating based on date/time

M

mikesoll

New Member
Joined
Sep 4, 2013
Messages
9
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..
Code: 
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
 
Sort by date Sort by votes
The import file contains a column called "Created Date" it is a custom format: "ddd mmm dd yyyy h:mm AM/PM" displays as: "Tue Sep 03 2013 11:04AM". Once this file is imported into the master macro template a few things happen, first the macro strips the time and uses VBA "Short Date" to replace it, it then hides this column in the results. I tried your recommendation however it seems to be highlighting rows based on the "Election Date" which is not the value I want the conditional highlight based on. I hope this helps ask me anything else that may help. Any input is greatly appreciated so thank you in advance!!
 
Upvote 0
This code is what you need to look at:

Code: 
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

You will need to see if the date also contains the time so you can evaluate for 24 hour prior. This portion of the code only tests the current date:
Code: 
If CStr(Range(cd & X).Value) = CStr(Date)

Jeff
 
Upvote 0
Can you post the part of the code that strips the time? Maybe you can have it leave the time in and we evaluate both the date and time. The code could be altered to format the cell to only show the date, but it would also contain the time.

Jeff
 
Upvote 0
Ok I'm struggling to locate the part that strips it out so I'll paste what I think it is as well as the entire macro itself. Thank you Jeff! Part #1
Code: 
finalcol = currws.Cells.Find("*", searchorder:=xlByColumns, searchdirection:=xlPrevious).Column
    For count = 1 To finalcol
        Select Case Trim(Cells(1, count).Text)
            Case "Proposal Date", "Election Due Date", "Created Date", "Approved/Election Date", "Regulatory Hearing Date", "Proposal Received Date"
                Columns(MyColumnLetter(count * 1)).NumberFormat = "m/d/yyyy"
Part #2 (This mentions the VBA Date "Short Date") Also, it references column AU which is the location of the "Created Date" column.
Code: 
Next
    
    Columns("X:X").Cut
    Columns("AN:AN").Insert shift:=xlToRight
    Columns("BA:BA").Cut
    Columns("AY:AY").Insert shift:=xlToRight
           
    finalrow = currws.Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
    For count = 2 To finalrow
        Range("AU" & count).Value = Format(Range("AU" & count).Value, "Short Date")
    Next
Part #3 I'm going to display the entire macro in this section in case I'm missing something and I probably am.
Code: 
Option Explicit
Sub find_Columns(control As IRibbonControl)
  Dim finalrow, finalcol, afinalrow, afinalcol As Long
  Dim fldialog As FileDialog
  
  Dim colHeaders() As Variant
  Dim dict As Scripting.Dictionary
  Dim count, i, x As Long
  Dim currwb, sourcewb As Workbook
  Dim currwbstr, sourcewbstr As String
  Dim currws, sourcews As Worksheet
  Dim electionsTitle, electionsFooter As String
  Dim tdate As Boolean
    
  colHeaders = Array("MEP Landman", "Proposal Date", "Election Due Date", "Project Type", "Proposed Operator", _
  "Property No", "Well Name", "CHK Division", "District", "Legal Description", "County", "State", "GEO Objective", _
  "MEP Entity", "MEP Prod WI", "MEP Prod WI", "MEP Prod NRI", "Total AFE", "MEP Total", "Approved/Election Date", _
  "Election", "Land Comments", "Other WI % Owners", "Regulatory Hearing Date", "JOA", "Prepay Required", "RsvCat", "Gross EUR MMCF", "Gross EUR MBO")
      
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  Set fldialog = Application.FileDialog(msoFileDialogFilePicker)
  fldialog.AllowMultiSelect = False
  fldialog.Show
  
  If fldialog.SelectedItems.count = 0 Then
    Exit Sub
  End If
  
  Set dict = New Scripting.Dictionary
  
  Set currwb = ActiveWorkbook
  currwbstr = ActiveWorkbook.Name
  Set currws = currwb.Worksheets("Proposals")
  
  With currws.Columns
    .Delete
  End With
  
  ActiveSheet.ResetAllPageBreaks
  
  sourcewbstr = fldialog.SelectedItems.Item(1)
  If InStr(1, LCase(sourcewbstr), "made", vbTextCompare) Then
    electionsTitle = "Elections Made"
    electionsFooter = "Elections_Made " & Date
Else
    electionsTitle = "Elections Pending"
    electionsFooter = "Elections_Pending " & Date
End If
  Workbooks.Open Filename:=sourcewbstr
  Set sourcewb = ActiveWorkbook
  sourcewbstr = ActiveWorkbook.Name
  Set sourcews = sourcewb.Worksheets("Sheet1")
  Worksheets("Sheet1").Activate
  finalcol = sourcews.Cells.Find("*", searchorder:=xlByColumns, searchdirection:=xlPrevious).Column
  finalrow = sourcews.Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
  Range("A1:" & MyColumnLetter(finalcol * 1) & finalrow).Copy
  Windows(currwbstr).Activate
  currws.Range("A1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=True, Transpose:=False
  sourcewb.Close False
     
    finalcol = currws.Cells.Find("*", searchorder:=xlByColumns, searchdirection:=xlPrevious).Column
    For count = 1 To finalcol
        Select Case Trim(Cells(1, count).Text)
            Case "Proposal Date", "Election Due Date", "Created Date", "Approved/Election Date", "Regulatory Hearing Date", "Proposal Received Date"
                Columns(MyColumnLetter(count * 1)).NumberFormat = "m/d/yyyy"
            Case "Property No"
                Columns(MyColumnLetter(count * 1)).NumberFormat = "General"
            Case "MEP Drill WI", "MEP Comp WI", "MEP Prod WI", "MEP Prod WI", "MEP Prod NRI"
                 Columns(MyColumnLetter(count * 1)).NumberFormat = "0.00000000"
            Case "MEP Net Acres Cal"
                Cells(1, count) = "MEP Net Acres"
                Columns(MyColumnLetter(count * 1)).NumberFormat = "0.00000"
            Case "Total AFE", "MEP Total"
                Columns(MyColumnLetter(count * 1)).NumberFormat = "$#,##0"
            Case Else
        End Select
    Next
    
    Columns("X:X").Cut
    Columns("AN:AN").Insert shift:=xlToRight
    Columns("BA:BA").Cut
    Columns("AY:AY").Insert shift:=xlToRight
           
    finalrow = currws.Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
    For count = 2 To finalrow
        Range("AU" & count).Value = Format(Range("AU" & count).Value, "Short Date")
    Next
        
    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
        
    Else
        ActiveWorkbook.Worksheets("Proposals").Sort.SortFields.Clear
        ActiveWorkbook.Worksheets("Proposals").Sort.SortFields.Add Key:=Range( _
            "AN2:AN" & finalrow), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:= _
            xlSortNormal
        ActiveWorkbook.Worksheets("Proposals").Sort.SortFields.Add Key:=Range( _
            "S2:S" & finalrow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
            xlSortNormal
        ActiveWorkbook.Worksheets("Proposals").Sort.SortFields.Add Key:=Range( _
            "U2:U" & finalrow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
            xlSortNormal
        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
        End If
    
    Rows(1).Insert shift:=xlDown, copyorigin:=xlFormatFromLeftOrAbove
    finalcol = currws.Cells.Find("*", searchorder:=xlByColumns, searchdirection:=xlPrevious).Column
    With currws.Range("A1:" & MyColumnLetter(finalcol * 1) & "2").Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .Color = 12835293
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    
    With currws.Range("A1:" & MyColumnLetter(finalcol * 1) & "2")
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
        .Font.Bold = True
    End With
    
    With currws.Range("A1")
        .Value = electionsTitle
        .WrapText = False
        .HorizontalAlignment = xlLeft
    End With
    
    formatBorders
    
currws.Columns.AutoFit
currws.Rows.AutoFit
finalcol = currws.Cells.Find("*", searchorder:=xlByColumns, searchdirection:=xlPrevious).Column
  
  
  For i = 0 To UBound(colHeaders)
      If Not dict.Exists(colHeaders(i)) Then
        dict.Add colHeaders(i), colHeaders(i)
    End If
  Next i
  
  For count = finalcol To 1 Step -1
    If Not dict.Exists(Trim(Cells(2, count))) Then Columns(count).Hidden = True
  Next
finalcol = currws.Cells.Find("*", searchorder:=xlByColumns, searchdirection:=xlPrevious).Column
currws.Range("A2:" & MyColumnLetter(finalcol * 1) & "2").AutoFilter
Columns.WrapText = True
Range("A1").WrapText = False
Rows("2:2").RowHeight = 38.25
finalcol = currws.Cells.Find("*", searchorder:=xlByColumns, searchdirection:=xlPrevious).Column
    For count = 1 To finalcol
        Select Case Trim(Cells(2, count).Text)
            Case "MEP Landman"
                Columns(count).ColumnWidth = 8.71
            Case "Proposal Date"
                Columns(count).ColumnWidth = 9.14
            Case "Election Due Date"
                Columns(count).ColumnWidth = 9.14
            Case "Project Type"
                Columns(count).ColumnWidth = 7.43
            Case "Regulatory Hearing Date"
                Columns(count).ColumnWidth = 15.29
            Case "Proposed Operator"
                Cells(2, count) = "Operator"
                Columns(count).ColumnWidth = 15.29
            Case "Property No"
                Columns(count).ColumnWidth = 7.86
            Case "Well Name"
                Columns(count).ColumnWidth = 19.29
            Case "CHK Division"
                Columns(count).ColumnWidth = 14.71
            Case "District"
                Columns(count).ColumnWidth = 13.14
            Case "Legal Description"
                Columns(count).ColumnWidth = 18.71
            Case "Prepay Required"
                Columns(count).ColumnWidth = 11.43
            Case "County"
                Columns(count).ColumnWidth = 8.43
            Case "State"
                Cells(2, count) = "St"
                Columns(count).ColumnWidth = 3.43
            Case "GEO Objective"
                Columns(count).ColumnWidth = 12.29
            Case "MEP Entity"
                Columns(count).ColumnWidth = 8
            Case "MEP Prod WI"
                Columns(count).ColumnWidth = 10.43
            Case "MEP Prod NRI"
                Columns(count).ColumnWidth = 10.57
            Case "Total AFE"
                Columns(count).ColumnWidth = 12.14
            Case "MEP Total"
                Columns(count).ColumnWidth = 10.71
'            Case "MEP Net Acres"
'                Columns(count).ColumnWidth = 7.71
            Case "Approved/Election Date"
                Columns(count).ColumnWidth = 9
            Case "Election"
                Columns(count).ColumnWidth = 9.71
            Case "JOA"
                Columns(count).ColumnWidth = 27.57
            Case "Other WI % Owners"
                Columns(count).ColumnWidth = 27.57
            Case "RsvCat", "Gross EUR MMCF", "Gross EUR MBO"
                Columns(count).ColumnWidth = 8.14
            Case "Land Comments"
                Columns(count).ColumnWidth = 50.29
            Case Else
        End Select
    Next
 finalrow = currws.Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
  
    With Rows("3:" & finalrow)
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlCenter
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
   
    Rows("3:" & finalrow).EntireRow.AutoFit
    
     With ActiveSheet.PageSetup
        .CenterHeader = "MEP Proposals"
        .RightHeader = electionsFooter
        .PrintTitleRows = "$1:$2"
    End With
Dim notToday As Long
For count = 3 To finalrow
  If Range("AU" & count).Value <> Date Then
        notToday = count
        Exit For
    End If
Next
If electionsTitle = "Elections Pending" Then
    Range("A" & notToday & ":BB" & finalrow).Select
    ActiveWorkbook.Worksheets("Proposals").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Proposals").Sort.SortFields.Add Key:=Range( _
        "D" & notToday & ":D" & finalrow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    ActiveWorkbook.Worksheets("Proposals").Sort.SortFields.Add Key:=Range( _
        "S" & notToday & ":S" & finalrow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    ActiveWorkbook.Worksheets("Proposals").Sort.SortFields.Add Key:=Range( _
        "U" & notToday & ":U" & finalrow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    ActiveWorkbook.Worksheets("Proposals").Sort.SortFields.Add Key:=Range( _
        "T" & notToday & ":T" & finalrow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    With ActiveWorkbook.Worksheets("Proposals").Sort
        .SetRange Range("A" & notToday & ":BB" & finalrow)
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
highlightFields
    
moveRegulatory
Worksheets("Proposals").Select
tdate = False
For count = 1 To finalrow
  If Range("AU" & count).Value = Date Then tdate = True
    If tdate = True And Range("AU" & count).Value <> Date Then
        ActiveWindow.SelectedSheets.HPageBreaks.Add Before:=Cells(count, 1)
        tdate = False
    End If
Next
End If
Dim reghear As String
For x = 1 To finalcol
    Select Case Trim(Cells(2, x).Text)
        Case "Regulatory Hearing Date"
            reghear = MyColumnLetter(x * 1)
            Exit For
    End Select
Next
Columns("AX:AZ").Cut
Columns("AL:AL").Insert shift:=xlToRight
Columns(reghear).Cut
Columns("E:E").Insert shift:=xlToRight
Columns("J:J").Cut
Columns("E:E").Insert shift:=xlToRight
Columns("Y:Y").Cut
Columns("G:G").Insert shift:=xlToRight

For x = 1 To finalcol
    Select Case Trim(Cells(2, x).Text)
        Case "Regulatory Hearing Date"
            reghear = MyColumnLetter(x * 1)
            Columns(reghear).Hidden = True
            Exit For
    End Select
Next
    
Range("A3").Select
ActiveWindow.FreezePanes = True
Set fldialog = Nothing
Set dict = Nothing
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Public Sub CreateTab(tname As String)
Dim wb As Workbook
Dim ws As Worksheet
Dim trg As Worksheet
checkforTab (tname)
Set wb = ActiveWorkbook
Set trg = wb.Worksheets.Add(After:=wb.Worksheets(wb.Worksheets.count))
trg.Name = tname
Set ws = wb.Worksheets(wb.Worksheets.count)
Set wb = Nothing
Set trg = Nothing
Set ws = Nothing
End Sub
Public Sub checkforTab(tname As String)
Dim wb As Workbook
Dim ws As Worksheet
Set wb = ActiveWorkbook
For Each ws In wb.Worksheets
    If LCase(ws.Name) = LCase(tname) Then
    Sheets(ws.Name).Delete
    End If
Next ws
End Sub
Function MyColumnLetter(MyColumn As Long)
  If MyColumn > 26 Then
    MyColumnLetter = Chr(Int((MyColumn - 1) / 26) + 64) & Chr(((MyColumn - 1) Mod 26) + 65)
  Else
    MyColumnLetter = Chr(MyColumn + 64)
  End If
End Function
Public Sub formatBorders()
Dim finalcol As Long
finalcol = Cells.Find("*", searchorder:=xlByColumns, searchdirection:=xlPrevious).Column
    Range("A2:" & MyColumnLetter(finalcol * 1) & "2").Borders(xlDiagonalDown).LineStyle = xlNone
    Range("A2:" & MyColumnLetter(finalcol * 1) & "2").Borders(xlDiagonalUp).LineStyle = xlNone
    With Range("A2:" & MyColumnLetter(finalcol * 1) & "2").Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Range("A2:" & MyColumnLetter(finalcol * 1) & "2").Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Range("A2:" & MyColumnLetter(finalcol * 1) & "2").Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Range("A2:" & MyColumnLetter(finalcol * 1) & "2").Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Range("A2:" & MyColumnLetter(finalcol * 1) & "2").Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Range("A2:" & MyColumnLetter(finalcol * 1) & "2").Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
End Sub
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

Public Sub moveRegulatory()
    Dim finalrow, finalcol, x, permrow, pasterow, i, count As Long
    Dim pt As String
    Dim foundReg As Boolean
    foundReg = False
    Dim newtab As String
    Dim c As Range
    Dim wb As Workbook
    Dim aws, cws As Worksheet
    
    Dim colHeaders() As Variant
    Dim dict As Scripting.Dictionary
      
  colHeaders = Array("MEP Landman", "Proposal Date", "Election Due Date", "Project Type", "Operator", _
  "Property No", "Well Name", "CHK Division", "District", "Legal Description", "County", "St", "GEO Objective", _
  "MEP Entity", "MEP Prod WI", "MEP Prod WI", "MEP Prod NRI", "Total AFE", "MEP Total", "Approved/Election Date", _
  "Election", "Land Comments", "Other WI % Owners", "Regulatory Hearing Date", "JOA", "MEP Net Acres", "Prepay Required", "RsvCat", "Gross EUR MMCF", "Gross EUR MBO")
     
    
    Set wb = ActiveWorkbook
    Set cws = Worksheets("Proposals")
    Set dict = New Scripting.Dictionary
    
    finalcol = Cells.Find("*", searchorder:=xlByColumns, searchdirection:=xlPrevious).Column
    finalrow = Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
    permrow = finalrow + 2
    pasterow = finalrow + 2
    
    For x = 1 To finalcol
        Select Case Trim(Cells(2, x).Text)
            Case "Project Type"
                pt = MyColumnLetter(x * 1)
                Exit For
        End Select
    Next
    For x = finalrow To 3 Step -1
        If LCase(Left(Range(pt & x), 10)) = "regulatory" Then
            foundReg = True
            Rows(x).Cut
            Rows(pasterow).Insert
            permrow = permrow - 1
            pasterow = Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row + 1
        End If
    Next
    If foundReg = False Then Exit Sub
    finalrow = Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
    Range("A" & permrow & ":BB" & finalrow).Select
    ActiveWorkbook.Worksheets("Proposals").Sort.SortFields.Clear
     ActiveWorkbook.Worksheets("Proposals").Sort.SortFields.Add Key:=Range( _
            "AH" & permrow & ":AH" & finalrow), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:= _
            xlSortNormal
    ActiveWorkbook.Worksheets("Proposals").Sort.SortFields.Add Key:=Range( _
        "S" & permrow & ":S" & finalrow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    ActiveWorkbook.Worksheets("Proposals").Sort.SortFields.Add Key:=Range( _
        "U" & permrow & ":U" & finalrow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    ActiveWorkbook.Worksheets("Proposals").Sort.SortFields.Add Key:=Range( _
        "T" & permrow & ":T" & finalrow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    With ActiveWorkbook.Worksheets("Proposals").Sort
        .SetRange Range("A" & permrow & ":BB" & finalrow)
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    cws.Range("A" & permrow & ":BB" & finalrow).Copy
    wb.Worksheets.Add After:=wb.Worksheets(wb.Worksheets.count)
    newtab = "Regulatory"
    Sheets(wb.Worksheets.count).Name = newtab
    Set aws = Worksheets(newtab)
    aws.Range("A2").PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks:=True, Transpose:=False
    cws.Rows(permrow & ":" & finalrow).Delete
    cws.Range("A2:BB2").Copy
    aws.Range("A1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=True, Transpose:=False
    Worksheets("Regulatory").Select
    aws.Rows(1).Insert shift:=xlDown, copyorigin:=xlFormatFromLeftOrAbove
    finalcol = aws.Cells.Find("*", searchorder:=xlByColumns, searchdirection:=xlPrevious).Column
    With aws.Range("A1:" & MyColumnLetter(finalcol * 1) & "2").Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .Color = 12835293
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    
    With aws.Range("A1:" & MyColumnLetter(finalcol * 1) & "2")
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
        .Font.Bold = True
    End With
    
    With aws.Range("A1")
        .Value = "Regulatory"
        .WrapText = False
        .HorizontalAlignment = xlLeft
    End With
    
    formatBorders
    
    aws.Columns.AutoFit
    aws.Rows.AutoFit
    
finalcol = aws.Cells.Find("*", searchorder:=xlByColumns, searchdirection:=xlPrevious).Column
aws.Range("A2:" & MyColumnLetter(finalcol * 1) & "2").AutoFilter
aws.Columns.WrapText = True
aws.Range("A1").WrapText = False
aws.Rows("2:2").RowHeight = 38.25
finalrow = aws.Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
  
    With Rows("3:" & finalrow)
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlCenter
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
 
 For i = 0 To UBound(colHeaders)
      If Not dict.Exists(colHeaders(i)) Then
        dict.Add colHeaders(i), colHeaders(i)
    End If
  Next i
  
  For count = finalcol To 1 Step -1
    If Not dict.Exists(Trim(Cells(2, count))) Then Columns(count).Hidden = True
  Next
 finalcol = aws.Cells.Find("*", searchorder:=xlByColumns, searchdirection:=xlPrevious).Column
    For count = 1 To finalcol
        Select Case Trim(Cells(2, count).Text)
            Case "MEP Landman"
                Columns(count).ColumnWidth = 8.71
            Case "Proposal Date"
                Columns(count).ColumnWidth = 9.14
            Case "Election Due Date"
                Columns(count).ColumnWidth = 9.14
            Case "Project Type"
                Columns(count).ColumnWidth = 7.43
            Case "Regulatory Hearing Date"
                Columns(count).ColumnWidth = 15.29
            Case "Operator"
                Columns(count).ColumnWidth = 15.29
            Case "Property No"
                Columns(count).ColumnWidth = 7.86
            Case "Well Name"
                Columns(count).ColumnWidth = 19.29
            Case "CHK Division"
                Columns(count).ColumnWidth = 14.71
            Case "District"
                Columns(count).ColumnWidth = 13.14
            Case "Legal Description"
                Columns(count).ColumnWidth = 18.71
            Case "Prepay Required"
                Columns(count).ColumnWidth = 11.43
            Case "County"
                Columns(count).ColumnWidth = 8.43
            Case "St"
                Columns(count).ColumnWidth = 3.43
            Case "GEO Objective"
                Columns(count).ColumnWidth = 12.29
            Case "MEP Entity"
                Columns(count).ColumnWidth = 8
            Case "MEP Prod WI"
                Columns(count).ColumnWidth = 10.43
            Case "MEP Prod NRI"
                Columns(count).ColumnWidth = 10.57
            Case "Total AFE"
                Columns(count).ColumnWidth = 12.14
            Case "MEP Total"
                Columns(count).ColumnWidth = 10.71
            Case "MEP Net Acres"
                Columns(count).ColumnWidth = 7.71
            Case "Approved/Election Date"
                Columns(count).ColumnWidth = 9
            Case "Election"
                Columns(count).ColumnWidth = 9.71
            Case "JOA"
                Columns(count).ColumnWidth = 27.57
            Case "Other WI % Owners"
                 Columns(count).ColumnWidth = 27.57
            Case "RsvCat", "Gross EUR MMCF", "Gross EUR MBO"
                Columns(count).ColumnWidth = 8.14
            Case "Land Comments"
                Columns(count).ColumnWidth = 50.29
            Case Else
        End Select
    Next
    
    Dim reghear As String
For x = 1 To finalcol
    Select Case Trim(Cells(2, x).Text)
        Case "Regulatory Hearing Date"
            reghear = MyColumnLetter(x * 1)
            Exit For
    End Select
Next
Columns("AX:AZ").Cut
Columns("AN:AN").Insert shift:=xlToRight
Columns(reghear).Cut
Columns("E:E").Insert shift:=xlToRight
Columns("J:J").Cut
Columns("F:F").Insert shift:=xlToRight
Columns("Y:Y").Cut
Columns("G:G").Insert shift:=xlToRight
Range("A3").Select
ActiveWindow.FreezePanes = True
format_Regulatory
Set dict = Nothing
End Sub
Sub format_Regulatory()
 With ActiveSheet.PageSetup
        .PrintTitleRows = "$1:$2"
        .LeftHeader = ""
        .CenterHeader = "MEP Proposals - Regulatory"
        .RightHeader = "Elections_Pending " & Date
        .LeftFooter = ""
        .CenterFooter = ""
        .RightFooter = "&P of &N"
        .LeftMargin = Application.InchesToPoints(0.5)
        .RightMargin = Application.InchesToPoints(0.5)
        .TopMargin = Application.InchesToPoints(0.5)
        .BottomMargin = Application.InchesToPoints(0.5)
        .HeaderMargin = Application.InchesToPoints(0.3)
        .FooterMargin = Application.InchesToPoints(0.3)
        .PrintHeadings = False
        .PrintGridlines = True
        .PrintComments = xlPrintNoComments
        .PrintQuality = 600
        .CenterHorizontally = False
        .CenterVertically = False
        .Orientation = xlLandscape
        .Draft = False
        .PaperSize = xlPaperLegal
        .FirstPageNumber = xlAutomatic
        .Order = xlDownThenOver
        .BlackAndWhite = False
        .Zoom = False
        .FitToPagesWide = 1
        .FitToPagesTall = False
        .PrintErrors = xlPrintErrorsDisplayed
        .OddAndEvenPagesHeaderFooter = False
        .DifferentFirstPageHeaderFooter = False
        .ScaleWithDocHeaderFooter = True
        .AlignMarginsHeaderFooter = True
        .EvenPage.LeftHeader.Text = ""
        .EvenPage.CenterHeader.Text = ""
        .EvenPage.RightHeader.Text = ""
        .EvenPage.LeftFooter.Text = ""
        .EvenPage.CenterFooter.Text = ""
        .EvenPage.RightFooter.Text = ""
        .FirstPage.LeftHeader.Text = ""
        .FirstPage.CenterHeader.Text = ""
        .FirstPage.RightHeader.Text = ""
        .FirstPage.LeftFooter.Text = ""
        .FirstPage.CenterFooter.Text = ""
        .FirstPage.RightFooter.Text = ""
    End With
End Sub
Again, Thank you for your time looking at this I am grateful!!
 
Upvote 0
This code here seems likely to be changing the dates:
Code: 
For Count = 2 To finalrow  Range("AU" & Count).Value = Format(Range("AU" & Count).Value, "Short Date")
Next

I would change it to this:
Code: 
For Count = 2 To finalrow  
Range("AU" & Count).Value = Format(Range("AU" & Count).Value, "mm/dd/yyyy hh:mm")
Range("AU" & Count).NumberFormat = "mm/dd/yyyy"
Next

This would leave the time in the value, but change the format of the cell to only show the date.

Jeff
 
Upvote 0
Excellent Jeff! I made the change and re-imported the data sheet, now the "Created Date" column is in a date/time format so 24 hour calculations should be achievable. I'm taking a lok at it but still a little lost in this code when looking at the "highlight" section and determining where the 24 hour calculation should go or written. Thanks again!
 
Upvote 0
This code evaluates the number of minutes difference between the current date and the cell date:
Code: 
Public Sub highlightFields()  

Dim finalrow, finalcol, x As Long
  Dim cd, election, elec_dd, proj_type As String
  
[COLOR=#ff0000]  Dim Nowmins As Long[/COLOR]
[COLOR=#ff0000]  Dim Cellmins As Long[/COLOR]
[COLOR=#ff0000]  Dim CellDate As Date[/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
  
[COLOR=#ff0000]  CellDate = Range(cd & x).Value[/COLOR]
[COLOR=#ff0000]  Nowmins = Minute(Now()) + Hour(Now()) * 60[/COLOR]
[COLOR=#ff0000]  Cellmins = Minute(CellDate) + Hour(CellDate) * 60[/COLOR]
[COLOR=#ff0000]  If 1440 - Cellmins + Nowmins < 1440 Then [/COLOR][COLOR=#0000cd]'the number of minutes in a day is 1,440[/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
 
Last edited:
Upvote 0
I've modified the code per your recommendations and then imported a new datasheet with records with a "Create Date" within the last 24 hours to test. The import is successful however it is highlighting records far outside the range of 24 hours, some over two weeks. I'm listing the section of code for the highlighting of records with the modifications you recommended (changes marked in red). Please let me know if I missed something or if there is another area I need to evaluate. Thank you in advance.

Code: 
Public Sub highlightFields()Dim finalrow, finalcol, x As Long
Dim cd, election, elec_dd, proj_type As String


[COLOR=#ff0000]'Code added to evaluate the number of minutes between the CollectDate and the CellDate [/COLOR]
[COLOR=#ff0000]Dim Nowmins As Long[/COLOR]
[COLOR=#ff0000]Dim Cellmins As Long[/COLOR]
[COLOR=#ff0000]Dim CellDate As Date[/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
        
[COLOR=#ff0000] 'Code added - 9/5/2013[/COLOR]
[COLOR=#ff0000] CellDate = Range(cd & x).Value[/COLOR]
[COLOR=#ff0000] Nowmins = Minute(Now()) + Hour(Now()) * 60[/COLOR]
[COLOR=#ff0000] Cellmins = Minute(CellDate) + Hour(CellDate) * 60[/COLOR]
[COLOR=#ff0000] If 1440 - Cellmins + Nowmins < 1440 Then 'the number of minutes in a day is 1,440[/COLOR]


            If Trim(Range(election & x).Value) <> "" Then
            With Range(election & x).Font
                .Bold = True
                .Color = -16776961
                .TintAndShade = 0
            End With
            End If
 
Upvote 0
You must log in or register to reply here.

Similar threads

L
  • Solved
VBA Find Cell from Date listed, in Columns, Return cell to highlight in color
Replies
7
Views
612
mumps
mumps
S
  • Solved
Conditional Formatting to highlight cells between to date
2
Replies
12
Views
995
PeteWright
PeteWright
E
  • Question Question
FIFO Macro giving different results each time it runs
Replies
7
Views
1K
Lee Wei Sin
L
S
  • Solved
Take 2 - Conditional Formatting to highlight cells between to date
2
Replies
15
Views
951
Stef9910
S
M
  • Question Question
VBA Code - Run Code if cell value is not blank
Replies
0
Views
652
MHamid
M

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top