VBA: Trouble Modifying Exisiting Excel VBA Macro to Highlight Rows based on 24 hours

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. Any help would be most appreciated for a new comer!
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" + "Short Time")
    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
 
Last edited:

Excel Facts

Links? Where??
If Excel says you have links but you can't find them, go to Formulas, Name Manager. Look for old links to dead workbooks & delete.
Sort by date Sort by votes
In the sub highlightFields you'll find the following if statement:
Code: 
If CStr(Range(cd & x).Value) = CStr(Date) Then

Depending on how the date of creation info is stored in the cells on your sheet, replacing that statement with this may work:
Code: 
If DateDiff("d", Date, Range(elec_dd & x).Value) <= 1 Then

If that doesn't work for you, I'd recommend posting more information about what date and time data is stored in your cells and how it is stored and then hoping someone wiser and more experienced than I comes along to help you out. The first if statment is the one which dictates the colors of cells created on the current date so it's just a matter of adjusting the if statement to capture the last 24 hours instead of just today's date.
 
Last edited:
Upvote 0
You must log in or register to reply here.

Similar threads

T
  • Question Question
Optimising my VBA to improve the efficiency of my Workbook
2 3
Replies
21
Views
2K
Tmini
T
D
  • Question Question
VBA code works when called directly, but not from another routhine
Replies
7
Views
944
davidepstein22
D
M
  • Question Question
Send email with rows based on expiration date
2
Replies
10
Views
1K
Musto85
M
A
  • Solved
Changing recorded macro to have dynamic selection of cells when trying to format a sheet.
Replies
4
Views
850
Michael M
Michael M
K
  • Solved
Sorting entire column's data based on dates in a row (VBA)
Replies
5
Views
1K
kevin9999
K

Forum statistics

Threads
1,223,228
Messages
6,170,874
Members
452,363
Latest member
merico17

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