Option Explicit

Sub sChecksumsSheetInsert()

    Dim intChecksumRow As Long, intIndexNumber As Long
    Dim lngNumberOfRows As Long
    Dim sht As Worksheet, shtAuditSheet As Worksheet
    Dim rng As Range
    Dim Wrkbk As Workbook
    On Error GoTo exit_proc

    AppSetting

    Set Wrkbk = ActiveWorkbook    'Add Audit Sheet & Format

    On Error Resume Next
    Sheets("Checksums").Delete
    On Error GoTo 0


    Sheets.Add.Name = "Checksums"
    Set shtAuditSheet = Sheets("Checksums")
    With shtAuditSheet
        .Move After:=Worksheets(Worksheets.Count)
        .Cells.Font.Name = "Calibri"
        .Cells.Font.Size = 9

        ActiveWindow.DisplayGridlines = False
        .Cells(3, 5).Select
        ActiveWindow.FreezePanes = True
        .Rows("1:1").RowHeight = 30
        .Rows("2:2").RowHeight = 7.5
        .Range("A:A,C:C,C:C,E:E,G:G,I:I").ColumnWidth = 1
        .Range("B:B,F:F").ColumnWidth = 12
        .Range("D:D").ColumnWidth = 30
        .Range("H:H").ColumnWidth = 50
        .Range("7:7,11:11").RowHeight = 20

        .Range("B4").FormulaR1C1 = "Model Name"
        .Range("B5").FormulaR1C1 = "Model Version"
        .Range("B4:B5").HorizontalAlignment = xlRight
        .Range("D4:D5").Font.Color = -65536
        .Range("D4:D5").Font.Bold = True
        .Range("D4").FormulaR1C1 = "Put Model Name here"
        .Range("D5").FormulaR1C1 = "Put Model Version here"

        .Range("B4:D5").Copy
        .Range("F4").PasteSpecial Paste:=xlPasteAll
        .Range("F4").FormulaR1C1 = "Tech Support"
        .Range("F5").FormulaR1C1 = "Contact Details"
        .Range("H4").FormulaR1C1 = "James Power, FD4Cast Ltd."
        .Range("H5").FormulaR1C1 = "E: james@fd4cast.com, T: 07967 883568"


        .Range("D5").Copy
        .Range("D12").PasteSpecial Paste:=xlPasteAll
        .Range("D12").FormulaR1C1 = "Click on Hyperlink to Navigate to Sheet"

        Set rng = .Range("B9")
        Wrkbk.Names.Add Name:="Audit_SumChk", RefersTo:=rng
        Set rng = .Range("B13")
        Wrkbk.Names.Add Name:="Audit_Start", RefersTo:=rng
        Set rng = .Range("F9")
        Wrkbk.Names.Add Name:="CustAudit_SumChk", RefersTo:=rng

        .Range("B1").FormulaR1C1 = "Audit Sheet"
        .Range("B1").VerticalAlignment = xlCenter
        .Range("B1").Font.FontStyle = "Regular"
        .Range("B1").Font.Bold = True
        .Range("B1").Font.Size = 18

        .Range("B1").Copy
        .Range("B7").PasteSpecial Paste:=xlPasteAll
        .Range("B7").FormulaR1C1 = "Summary Sheet Error Checks"
        .Range("B7").Font.Size = 14

        .Range("B7").Copy
        .Range("B11").PasteSpecial Paste:=xlPasteAll
        .Range("B11").FormulaR1C1 = "Sheet Error Checks"

        .Range("B7").Copy
        .Range("F7").PasteSpecial Paste:=xlPasteAll
        .Range("F7").FormulaR1C1 = "Summary Custom Checks"

        .Range("B7").Copy
        .Range("F11").PasteSpecial Paste:=xlPasteAll
        .Range("F11").FormulaR1C1 = "Custom Checks"

        .Range("D9").FormulaR1C1 = "Sheets"
        .Range("D9").Font.Size = 9

        'Add Summary Cell

        '    Application.DisplayAlerts = False
        .Range("B9").Font.Name = "Calibri"
        .Range("B9").Font.FontStyle = "Regular"
        .Range("B9").Font.Size = 8
        .Range("B9").HorizontalAlignment = xlCenter
        .Range("B9").VerticalAlignment = xlBottom
        .Range("B9").Interior.Color = 255
        .Range("B9").Font.Color = RGB(255, 255, 255)

        .Range("B9").Select

        With Wrkbk
            If Val(Application.Version) < 12 Then
                With Selection.FormatConditions
                    .Add Type:=xlCellValue, Operator:=xlEqual, Formula1:="TRUE"
                    Selection.FormatConditions(1).Font.ColorIndex = 2
                    Selection.FormatConditions(1).Interior.ColorIndex = 50
                End With
            Else
                With Selection.FormatConditions
                    .Add Type:=xlCellValue, Operator:=xlEqual, Formula1:="=TRUE"
                    Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
                End With
                With Selection.FormatConditions(1).Font
                    .Color = RGB(255, 255, 255)
                End With
                With Selection.FormatConditions(1).Interior
                    .PatternColorIndex = xlAutomatic
                    .Color = 6723891
                End With
            End If
        End With

        .Range("B9").Copy
        .Range("B13").PasteSpecial Paste:=xlPasteAll
        .Range("F9").PasteSpecial Paste:=xlPasteAll

        intChecksumRow = 13
        intIndexNumber = 1

        Do While .Range("Audit_Start").Offset(intIndexNumber - 1).Formula <> ""
            intIndexNumber = intIndexNumber + 1
        Loop

        For Each sht In Sheets
            If sht.Name <> "Checksums" Then
                Worksheets("Checksums").Activate
                intChecksumRow = .Range("Audit_Start").Offset(intIndexNumber, 0).Row

                .Range(Cells(intChecksumRow - 1, "A"), Cells(intChecksumRow - 1, "D")).Select
                Selection.AutoFill Destination:=.Range(.Range(.Cells(intChecksumRow - 1, "B"), .Cells(intChecksumRow - 1, "D")), _
                                                       .Range(.Cells(intChecksumRow, "A"), .Cells(intChecksumRow, "D"))), Type:=xlFillCopy

                lngNumberOfRows = .Rows.Count
                .Cells(intChecksumRow, "B").Formula = "=IF(ISERROR(SUM('" & sht.Name & "'!1:" & lngNumberOfRows & ")),FALSE,TRUE)"
                'Cells(intChecksumRow, "B").Formula = "=IF(ISERROR(SUM('" & sht.Name & "'!1:" & sht.UsedRange.Rows.Count & ")),FALSE,TRUE)"

                .Cells(intChecksumRow, "D").Formula = sht.Name
                intIndexNumber = intIndexNumber + 1
            End If
        Next sht

        .Rows("13:13").Delete Shift:=xlUp

        'Begin Inserting Sheet Checksums

        Set rng = .Range("B13")

        Wrkbk.Names.Add Name:="Audit_Start", RefersTo:=rng

        .Range("B9").FormulaR1C1 = "=IF(COUNTIF(R13C:R" & lngNumberOfRows & "C,FALSE)<>0,FALSE,TRUE)"
        .Range("F9").FormulaR1C1 = "=IF(COUNTIF(R13C:R" & lngNumberOfRows & "C,FALSE)<>0,FALSE,TRUE)"

        Set rng = .Range("F13")
        Wrkbk.Names.Add Name:="CustAudit_Start", RefersTo:=rng

        .Range("Audit_Start").Copy
        .Range("CustAudit_Start").PasteSpecial Paste:=xlPasteAll
        .Range("CustAudit_Start").FormulaR1C1 = "=IF(1=1,TRUE,FALSE)"


        .Range("H13").FormulaR1C1 = "Create custom checks here, e.g. =IF(X<>Y,FALSE,TRUE). " & _
                                    "Copy from cell F2 to create new custom checksums."
    End With
    Call sPutHyperlinks

    Call sApplyCondFormatting
    'Call sInsertButtons

    Set rng = Nothing
    Set sht = Nothing
    Set shtAuditSheet = Nothing
    Set Wrkbk = Nothing

    '    Range("A1").Select


    MsgBox "Checksums Sheet Created in " & ActiveWorkbook.Name & "!", vbExclamation, "Success"

    AppSetting ("Reset")

    Exit Sub

exit_proc:

    AppSetting ("Reset")
    MsgBox ("Implementation error. Please seek technical support:-" & Chr(13) & Chr(13) & _
            "James Power, james@fd4cast.com, T: 07967 883568")

End Sub

Sub sPutHyperlinks()

    Dim rngSheet As Range, rngFind As Range
    Dim lngHeaderRow As Long, lngRow As Long
    Dim shtAuditSheet As Worksheet

    '    Sheets("Checksums").Activate ' not needed
    Set shtAuditSheet = Sheets("Checksums")

    lngHeaderRow = 13

    With shtAuditSheet
        Set rngSheet = .UsedRange
        lngRow = .Cells(.Rows.Count, "D").End(xlUp).Row

        Set rngFind = .Range(.Cells(lngHeaderRow, 4), .Cells(lngRow, 4))

        sReplaceTextWithHyperlinks rngFind
    End With
    Set rngSheet = Nothing
    Set rngFind = Nothing
    Set shtAuditSheet = Nothing


End Sub

Sub sReplaceTextWithHyperlinks(textRange As Range)

    Dim rng As Range
    Dim Wrkbk As Workbook
    Dim strAdress As String

    With textRange.Worksheet
        For Each rng In textRange
            With rng
                strAdress = Chr(39) & .Text & Chr(39) & "!A1"
                .Hyperlinks.Add Anchor:=rng, Address:="", SubAddress:= _
                                strAdress, TextToDisplay:=.Text
                .Font.Name = "Calibri"
                .Font.FontStyle = "Regular"
                .Font.Size = 9
                .Font.Bold = True
            End With
        Next rng
    End With

    Set Wrkbk = ThisWorkbook

    '    Wrkbk.Styles("FollowedHyperlink").Font.Name = "Calibri"
    '    Wrkbk.Styles("FollowedHyperlink").Font.Size = 9
    '    Wrkbk.Styles("FollowedHyperlink").Font.ThemeColor = xlThemeColorHyperlink
    '
    '    With .Styles("Hyperlink")
    '        .BaseStyle = "Default Paragraph Font"
    '        .Font.Underline = wdUnderlineSingle
    '        .Font.Color = wdColorBlue
    '    End With
    '
    '    With .Styles("FollowedHyperlink")
    '        .BaseStyle = "Default Paragraph Font"
    '        .Font.Underline = wdUnderlineSingle
    '        .Font.Color = wdColorPlum
    '    End With
    '

    Set rng = Nothing
    Set Wrkbk = Nothing

End Sub

Sub sApplyCondFormatting()

    Dim sht As Worksheet

    Call AppSetting

    For Each sht In ThisWorkbook.Sheets

        '   .DisplayGridlines = False
        With Range("A1")
            .FormatConditions.Add Type:=xlExpression, Formula1:= _
                                  "=OR(Audit_SumChk=FALSE,CustAudit_SumChk=FALSE)"
            .FormatConditions(Range("A1").FormatConditions.Count).SetFirstPriority
            .FormatConditions(1).Interior.Color = 255
            .FormatConditions(1).StopIfTrue = True
        End With
    Next sht

    Call AppSetting("Reset")
    Set sht = Nothing

End Sub

Sub sAddCustomChecksum()

    Dim lngRow As Long
    Dim shtAuditSheet As Worksheet

    '    Sheets("Checksums").Activate 'unnecssary
    Set shtAuditSheet = Worksheets("Checksums")

    'Find last used row in column F so as to add next checksum

    With shtAuditSheet
        lngRow = .Cells(.Rows.Count, 6).End(xlUp).Row + 1

        .Range("CustAudit_SumChk").Copy
        .Cells(lngRow, 6).PasteSpecial Paste:=xlPasteAll
        .Cells(lngRow, 6).FormulaR1C1 = "=IF(1=1,TRUE,FALSE)"
        .Cells(lngRow, 8).FormulaR1C1 = _
        "Create custom checks here, e.g. =IF(X<>Y,FALSE,TRUE)"
        '    .Cells(lngRow, 6).Select 'unnecessary
        Application.CutCopyMode = False
    End With

    Set shtAuditSheet = Nothing

End Sub


Public Sub AppSetting(Optional arg1 As String = "")
'Get current settings
    Dim lCalc As Long
    Dim sOldAlerts As String
    
    If arg1 = "" Then
        lCalc = Application.Calculation
        sOldAlerts = Application.DisplayAlerts
        With Application
            .Calculation = xlCalculationManual
            .ScreenUpdating = False
            .DisplayAlerts = False
        End With
    Else
        With Application
            .Calculation = lCalc
            .ScreenUpdating = True
            .DisplayAlerts = True
        End With
    End If
End Sub