Excel VBA

Re-Arrange File

First figure out where things are before I move them around and then build an ENUM so I don't have to remember the columns numbers as I am changing things.

'+----------------------------------------------------------+
'|        Created by Alan Barasch                           |
'|        09/18/2023   Vers 1.0                             |
'+----------------------------------------------------------+
'|  1. Remove header rows 1-5                               |
'|  2. Move birthdates to Col 1                             |
'|  3. Remove apostrophes from beginning and end of date    |
'|    3a. Fix format of birthdates                          |
'|  4. Remove (314) from phone’s numbers                    |
'|  5. Remove H and/or C suffix from phone numbers          |
'|  6. Sort names by birthdate                              |
'|  7. Set font to Proxima 14                               |
'|  *  Headers and footer on printed                        |
'+----------------------------------------------------------+

Enum Pos		'Enumerate positions
    DateB = 4
    DateA = 1
    Fname = 2
    Phone1 = 3
    Phone2 = 4
End Enum

Sub FixJFSbirthdays()
    Dim LastRow     As Long
    Dim LastCol     As Long
    Dim C           As Long
    Dim R           As Long
    Dim X           As Long
    Dim I           As Long
    Dim Ticker      As String
    Dim ActSheet    As String
    'Ask questions BEFORE doing anythings
    I = MsgBox("This utility will remove tick marks (') from dates and re-format the columns. Click NO to stop!" & vbCrLf _
        & "Ready to go?", vbYesNo, "Ready?")
    If I = 7 Then GoTo Canceled
    'Questions results
    
    
    ActSheet = ActiveSheet.Name 'Whats the name
    Rows("1:5").Select
    Selection.Delete Shift:=xlUp
    Columns("D:D").Select
    Selection.Cut
    Columns("A:A").Select
    Selection.Insert Shift:=xlToRight
      
    Ticker = Chr(39)    ' '
    LastRow = Range(Cells(999999, 1).Address).End(xlUp).Row
    LastCol = ActiveSheet.Cells.SpecialCells(xlLastCell).Column
    
    Application.ScreenUpdating = False  'Turn off moving around
    
    For R = 2 To LastRow
        'Step thru rows and make all fixes for each row
        Cells(R, Pos.DateA) = Mid(Cells(R, Pos.DateA), 2, Len(Cells(R, Pos.DateA)) - 2) 'Ticks removed
        X = X + 2
        If Left(Cells(R, Pos.Phone1), 6) = "(314) " Then     'Phone 1
            Cells(R, Pos.Phone1) = Mid(Cells(R, Pos.Phone1), 7, 8)
            C = C + 1
        End If
        If Left(Cells(R, Pos.Phone2), 6) = "(314) " Then     'Phone 2
            Cells(R, Pos.Phone2) = Mid(Cells(R, Pos.Phone2), 7, 8)
            C = C + 1
        End If
        Select Case Right(Cells(R, Pos.Phone1), 1) 'Clean non-314 numbers
            Case "C"
                Cells(R, Pos.Phone1) = Left(Cells(R, Pos.Phone1), Len(Cells(R, Pos.Phone1)) - 1)
            Case "H"
                Cells(R, Pos.Phone1) = Left(Cells(R, Pos.Phone1), Len(Cells(R, Pos.Phone1)) - 1)
            Case Else
        End Select
        Select Case Right(Cells(R, Pos.Phone2), 1)     'Clean more 314 numbers
            Case "C"
                Cells(R, Pos.Phone2) = Left(Cells(R, Pos.Phone2), Len(Cells(R, Pos.Phone2)) - 1)
            Case "H"
                Cells(R, Pos.Phone2) = Left(Cells(R, Pos.Phone2), Len(Cells(R, Pos.Phone2)) - 1)
            Case Else
        End Select
        
    Next R
    Application.ScreenUpdating = True
    Range(Cells(1, 1), Cells(LastRow, LastCol)).Font.Name = "Proxima"
    Range(Cells(1, 1), Cells(LastRow, LastCol)).Font.Size = 14
   ' SORT HERE
   
   'File name captured at top
    ActiveWorkbook.Worksheets(ActSheet).Sort.SortFields.Add2 Key:= _
        Range(Cells(2, Pos.DateA), Cells(LastRow, Pos.DateA)), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal    'Birthday
    ActiveWorkbook.Worksheets(ActSheet).Sort.SortFields.Add2 Key:= _
        Range(Cells(2, Pos.Fname), Cells(LastRow, Pos.Fname)), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal    'Name
    With ActiveWorkbook.Worksheets(ActSheet).Sort   'Sort
        .SetRange Range(Cells(1, 1), Cells(LastRow, LastCol))
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Range("A1:D1").Select
    Selection.Font.Bold = True
    Columns("A:D").Select
    Range("D1").Activate
    Columns("A:D").EntireColumn.AutoFit 'Addtl pretty
    Range("A2").Select
   'End Sort
    FormatHeadings LastCol, LastRow, ActSheet
    Cells(1, 1).Select
    MsgBox X & " tick marks (" & Ticker & ") were removed from dates and " _
        & C & " area codes fixed. Columns were formatted, etc.", vbInformation, "Completed"
    
    Exit Sub
Canceled:
    MsgBox "You chose to cancel the process!", vbCritical, "Stopped Process"
    
End Sub

Sub FormatHeadings(LastCol, LastRow, ActSheet)
    'Make headers and footers preLty
    ActiveWorkbook.Worksheets(ActSheet).Activate
    
    Application.PrintCommunication = True
    ActiveSheet.PageSetup.PrintArea = Range(Cells(2, Pos.DateA), Cells(LastRow, LastCol)).Address 
		'ActiveSheet.UsedRange.Address


    ActiveSheet.PageSetup.PrintTitleRows = "$1:$1"
    Application.PrintCommunication = False
    With ActiveSheet.PageSetup
        .LeftHeader = ""
        .CenterHeader = "Confidential Property of JKS"
        .RightHeader = "&D  &T"
        .LeftFooter = "&Z&F"
      '  .CenterFooter = "&A"
        .RightFooter = "&P of &N"
        .LeftMargin = Application.InchesToPoints(0.7)
        .RightMargin = Application.InchesToPoints(0.7)
        .TopMargin = Application.InchesToPoints(0.75)
        .BottomMargin = Application.InchesToPoints(0.75)
        .HeaderMargin = Application.InchesToPoints(0.3)
        .FooterMargin = Application.InchesToPoints(0.3)
        .PrintHeadings = False
        .PrintGridlines = True
        .PrintComments = xlPrintNoComments
        .PrintQuality = 600

        .CenterHorizontally = False
        .CenterVertically = False
        .Orientation = xlPortrait
        .Draft = False
        .PaperSize = xlPaperLetter
        .FirstPageNumber = xlAutomatic
        .Order = xlDownThenOver
        .BlackAndWhite = False
        .Zoom = False
        .FitToPagesWide = 1
     '   .FitToPagesTall = 1
        .PrintErrors = xlPrintErrorsDisplayed
        .OddAndEvenPagesHeaderFooter = False
        .DifferentFirstPageHeaderFooter = False
        .ScaleWithDocHeaderFooter = True
        .AlignMarginsHeaderFooter = True

    End With
    Application.PrintCommunication = True
 	'  Back to main
End Sub