Sub Sorted()
Dim v As Variant, res As Variant
Dim rng As Range, s As String
Dim i As Long
v = Array("Forename", _
"Initial", _
"Surname", _
"DOB", _
"Ethnicity", _
"Gender", _
"Centre Candidate ID.")
With ActiveSheet 'With Worksheets("Sheet1")
Set rng = .Range(.Cells(1, 1), _
.Cells(1, Columns.Count).End(xlToLeft))
End With
For i = LBound(v) To UBound(v)
res = Application.Match(v(i), rng, 0)
If IsError(res) Then
s = s & v(i) & ", "
End If
Next
If Len(Trim(s)) > 0 Then
s = Left(s, Len(s) - 2)
MsgBox "Missing headers: " & vbNewLine _
& s, 48, "Mandatory Header Check"
Else: GoTo DupChk:
End If
Exit Sub
'check for duplicate headers
DupChk:
Dim firstCell As Range, lastCell As Range
Dim cellCompare As Range, rngCompareTo As Range
Dim cellComareTo As Range
Set firstCell = Range("a1")
Set lastCell = firstCell.SpecialCells(xlCellTypeLastCell)
Set lastCell = Cells(1, lastCell.Column)
For Each cellCompare In Range(firstCell, _
lastCell.Offset(0, -1)).Cells
If cellCompare <> "" Then
Set rngCompareTo = _
Range(cellCompare.Offset(0, 1), lastCell)
For Each cellCompareTo In rngCompareTo.Cells
If cellCompareTo = cellCompare Then
MsgBox "There's a duplicate Header in row 1." & vbCrLf & vbCrLf & _
"Please delete and run Sort NCFE Mandatory Headers by Column Button", 48, "Duplicate Check"
Exit Sub
End If
Next cellCompareTo
End If
Next cellCompare
Application.ScreenUpdating = False
KeepArr = Array("Forename", "Initial", "Surname", "DOB", "Ethnicity", "Gender", "Centre Candidate ID.")
For i = Cells(1, Columns.Count).End(xlToLeft).Column To 1 Step -1
holder = 0
On Error Resume Next
holder = WorksheetFunction.Match(Cells(1, i), KeepArr, 0)
On Error GoTo 0
If holder = 0 Then Cells(1, i).EntireColumn.Delete
Next i
Rows("1:1").Insert
lastcol = Cells(2, Columns.Count).End(xlToLeft).Column
For i = 1 To lastcol
Cells(1, i).Value = WorksheetFunction.Match(Cells(2, i), KeepArr, 0)
Next i
Range("a1", Cells(1, lastcol)).EntireColumn.Sort key1:=Range("A1"), Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlLeftToRight
Rows("1:1").Delete
Range("A1").Select
Run "MakeLegible"
Application.ScreenUpdating = True
End Sub