Function range(a As range)
mmax = Application.WorksheetFunction.Max(a)
mmin = Application.WorksheetFunction.Min(a)
spread = Abs(mmax - mmin)
End Function

Sub UnHideSheets()
For Each Sheet In ActiveWorkbook.Sheets
    If Sheet.Visible = False Then Sheet.Visible = True
Next
    
End Sub

Sub okRefitColumns()
    Columns.AutoFit
End Sub

Sub okCAGeneral()
    If Selection.HorizontalAlignment = xlCenterAcrossSelection Then
        Selection.HorizontalAlignment = xlGeneral
    Else
        Selection.HorizontalAlignment = xlCenterAcrossSelection
    End If
End Sub

Sub okDuplicateRow()
    Application.ScreenUpdating = False
    With ActiveCell.EntireRow
        .Copy
        .Insert
    End With
    With Application
        .CutCopyMode = False
        .ScreenUpdating = True
    End With
End Sub

Sub okDuplicateRowRev()
    On Error Resume Next
        ActiveCell(2).EntireRow.Delete
    On Error GoTo 0
End Sub

Sub okColourCycle()
With Selection.Interior
    Select Case .ColorIndex
        Case -4142: .ColorIndex = 35
        Case 35: .ColorIndex = 39
        Case 39: .ColorIndex = 36
        Case 36: .ColorIndex = 37
        Case 37: .ColorIndex = 40
        Case 40: .ColorIndex = 34
        Case 34: .ColorIndex = 38
        Case Else: .ColorIndex = Null
    End Select
End With
End Sub

Set SelectR = ActiveWindow.RangeSelection
    For Each Area In SelectR.Areas
        With Area
            .Select
            .Copy
            t = .Top
            h = .Height
            l = .Left
            w = .Width
        End With
        With ActiveSheet.Pictures.Paste(Link:=True)
            .Name = "OnePic"
            .ShapeRange.Fill.Solid
            .Top = t + h + 1
            .Left = l + w + 1
            .Top = t
            .Left = l
            .ShapeRange.ScaleWidth 1, msoFalse, msoScaleFromMiddle
            .ShapeRange.ScaleHeight 1, msoFalse, msoScaleFromMiddle
            .ShapeRange.Line.Weight = 1
            .ShapeRange.Fill.ForeColor.SchemeColor = 1
        End With
    Next Area
    SelectR.Select

Sub CreateRangesFromList()
'This procedure creates new range names in the active workbook
'using a 2-column range of cells that contains:
'Col 1: the text of the range name to be created
'Col 2: text of the RefersTo definition (in proper format: ="somesheet!someref")
   Dim intRCount As Integer
   Dim intRRef As Integer
   
   Dim strSelAddr As String
   Dim rngBase As Range
   
   On Error GoTo FailTrap
   With selection
      If .Columns.Count <> 2 Then
         MsgBox Title:="Invalid Base Range", _
               Prompt:="Range does not contain exactly 2 columns", _
               Buttons:=vbCritical + vbOKOnly
         Exit Sub
      End If
      intRCount = .Rows.Count
      Set rngBase = .Cells(1, 1)
   End With
   
   With rngBase
         
      For intRRef = 1 To intRCount

         On Error Resume Next
         ActiveWorkbook.Names.Add _
            Name:=.Cells(intRRef, 1).Formula, _
            RefersTo:=.Cells(intRRef, 2).Formula
         If Err.Number <> 0 Then
            MsgBox Title:="Problem with this item:", _
                  Prompt:=.Offset(RowOffset:=intRRef).Address
         End If
      Next intRRef
   End With
   Set rngBase = Nothing
Exit Sub

FailTrap:
   Set rngBase = Nothing
   MsgBox Title:="Problems Encountered", _
         Prompt:="Check list for invalid Range Name Text and/or Refers_To values.", _
         Buttons:=vbCritical + vbOKOnly
         
End Sub

Function compare(Cell1 As range, cell2 As range)
    If Not Cell1.HasFormula And Not cell2.HasFormula Then
        'Neither have formulae, don't compare values, automatic pass
        compare = True
    ElseIf Cell1.HasFormula And cell2.HasFormula Then
        'Both have formulae, compare formulae
        compare = Cell1.FormulaR1C1 = cell2.FormulaR1C1
    Else
        'One has formula, one not, automatic fail
        compare = False
    End If
End Function