Consulting

Results 1 to 2 of 2

Thread: VBA: Change conditionally highlighted rows from current date to 24 hours

  1. 09-04-2013, 10:37 AM #1
    mikesoll
    mikesoll is offline
    VBAX Newbie
    Joined
    Sep 2013
    Posts
    2
    Location

    VBA: Change conditionally highlighted rows from current date to 24 hours

    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.. There is additional code that you may want to see I wanted to try to keep it simple... 
    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
    Reply With Quote Reply With Quote
  2. 09-04-2013, 10:39 AM #2
    mikesoll
    mikesoll is offline
    VBAX Newbie
    Joined
    Sep 2013
    Posts
    2
    Location
    I wanted to include the entire VBA module in case I missed something that would be useful. 
    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
    Reply With Quote Reply With Quote
« Previous Thread | Next Thread »

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •  

Forum Rules