Extracting VBA from: RCBuneq.xls
Contains VBA: True

============================================================
--- Module1.bas ---
============================================================
Attribute VB_Name = "Module1"
Public NoWorries As Boolean
Option Explicit
Sub randomise()
'
' randomise Macro
' Macro recorded 31/10/2004 by Brown
'

    Dim TotalUnits As Long
    Dim TotalReps As Integer
    Dim Counter1 As Integer
    Dim Counter2 As Integer
    Dim Counter3 As Integer
    Dim Response As Integer
    Dim nTreat As Range
    Dim nBlock As Range
    Dim C As Range
    Dim TreatName As Range
    Dim TreatRep As Range
    Dim TreatRange As Range
    Dim TreatRangeAll As Range
    Application.ScreenUpdating = False
    
' Check errors in input
    Worksheets("Describe experiment").Activate
    Set nTreat = Range("B10")
    Set nBlock = Range("B13")
    Set TreatName = Range("C18", Cells(nTreat.Value + 17, 3))
    Set TreatRep = Range("D18", Cells(nTreat.Value + 17, 4))
    TotalReps = Application.WorksheetFunction.Sum(TreatRep)
    TotalUnits = TotalReps * nBlock.Value
    NoWorries = True
    Range("B7").Select
    If nTreat < 2 Then
        Range("B10").Select
        SuddenStop
        Response = MsgBox("Minimum 2 treatments", 0, "Edgar II")
    End If
    If NoWorries And IsError(TotalReps) Then
        SuddenStop
        Response = MsgBox("Min 1 rep needed of each treatment", 0, "Edgar II")
    End If
    If NoWorries And nBlock < 1 Then
        Range("B13").Select
        SuddenStop
        Response = MsgBox("Minimum 1 block", 0, "Edgar II")
    End If
    If NoWorries And TotalUnits > 5000 Then
        SuddenStop
        Response = MsgBox("Max 5000 units in total", 0, "Edgar II")
    End If
    If NoWorries Then
        For Counter1 = 1 To nTreat
            If NoWorries And Cells(Counter1 + 17, 4) = 0 Then
                Response = MsgBox("Min 1 rep needed of each treatment", 0, "Edgar II")
                Cells(Counter1 + 17, 4).Select
                SuddenStop
                ActiveCell.Offset(1, 0).Range("A1").Select
                ActiveCell.Offset(-1, 0).Range("A1").Select
            End If
        Next Counter1
    End If
    If NoWorries Then
    If nTreat < 500 Then Range(Cells(18 + nTreat, 3), Cells(517, 4)).ClearContents
    With ActiveWindow
        .ScrollRow = 1
        .ScrollColumn = 1
    End With
    
' Design sheet header
    Worksheets("Design, list").Activate
    Cells.Borders.LineStyle = xlNone
    Range("A3") = "x"
    Range("A3", Range("A3").SpecialCells(xlLastCell)).EntireRow.Delete
    Range("A3").Formula = "=""Experiment: ""&'Describe experiment'!B7"
    Range("A4").Formula = "=""Designed: ""&'Describe experiment'!A3"
    Range("A3", "A4").Copy
    Range("A3", "A4").PasteSpecial xlPasteValues
    With Rows("3:4")
        .Font.Name = "Arial"
        .Font.Size = 12
        .RowHeight = 15
    End With

' Random numbers and treatments
    Counter3 = 0
    For Counter1 = 1 To nTreat
        For Counter2 = 1 To Worksheets("Describe experiment").Cells(17 + Counter1, 4)
            Counter3 = Counter3 + 1
            Cells(Counter3 + 6, 1) = Worksheets("Describe experiment").Cells(17 + Counter1, 3)
            If Cells(Counter3 + 6, 1) = "" Then Cells(Counter3 + 6, 1) = Worksheets("Describe experiment").Cells(17 + Counter1, 2)
        Next Counter2
    Next Counter1
    Set TreatRange = Range("A7", Cells(TotalReps + 6, 1))
    Set TreatRangeAll = Range("A7", Cells(TotalUnits + 6, 1))
    TreatRange.Copy
    TreatRangeAll.PasteSpecial xlPasteValues
    Range("B7") = TotalReps
    Range("H7").FormulaR1C1 = "=R[-1]C+1"
    Range("F7").FormulaR1C1 = "=RC1"
    Range("D7").FormulaR1C1 = "=int((RC8-1)/R7C2)+1"
    Range("E7").FormulaR1C1 = "=mod(RC8-1,R7C2)+1"
    Range("G7").Formula = "=RC4+rand()"

    Range("D7:H7").Copy
    With Range("D7", Cells(TotalUnits + 6, 8))
        .PasteSpecial xlPasteFormulas
        .Copy
        .PasteSpecial xlPasteValues
    End With

' Randomise order of treatments
    Range("F7", Range("G7").End(xlDown)).Sort Key1:=Range("G7"), Order1:=xlAscending, Header:=xlNo, _
        MatchCase:=False, Orientation:=xlTopToBottom
    Range("G7", Range("H7").SpecialCells(xlLastCell)).ClearContents

' Tidy up Design columns
    Range("C6") = "Unit"
    Range("D6").Formula = "=IF('Describe experiment'!B12="""",""Block"",proper('Describe experiment'!B12))"
    Range("E6").Formula = "=IF('Describe experiment'!B15="""",""Plot"",proper('Describe experiment'!B15))"
    Range("F6").Formula = "=IF('Describe experiment'!B9="""",""Variety"",proper('Describe experiment'!B9))"
    Rows("6:6").Font.Bold = True
    With Rows("3:6")
        .Copy
        .PasteSpecial Paste:=xlPasteValues
    End With
    Range("C7") = 1
    With Range("C8", Cells(TotalUnits + 6, 3))
        .FormulaR1C1 = "=R[-1]C+1"
        .Copy
        .PasteSpecial xlPasteValues
    End With
    With Columns("C:F")
        .EntireColumn.AutoFit
        .HorizontalAlignment = xlCenter
    End With
    Columns("A:A").ColumnWidth = Columns("C:C").ColumnWidth + 6
    Columns("B:B").ColumnWidth = Columns("D:D").ColumnWidth + 6
    Columns("C:C").ColumnWidth = Columns("E:E").ColumnWidth + 6
    Columns("D:D").ColumnWidth = Columns("F:F").ColumnWidth + 6
    Range("A6", Range("C7").End(xlDown).Offset(0, -1)).Delete Shift:=xlToLeft
    Columns("E:H").ColumnWidth = 8.43

' Remove unnecessary cells
    Cells(TotalUnits + 7, 5) = "x"
    Range(Cells(TotalUnits + 7, 5), Cells(TotalUnits + 7, 5).SpecialCells(xlLastCell)).EntireRow.Delete
    Cells(TotalUnits + 7, 5) = "x"
    Range(Cells(TotalUnits + 7, 5), Cells(TotalUnits + 7, 5).SpecialCells(xlLastCell)).EntireColumn.Delete

' Borders
    With Range("A7", Range("A7").End(xlDown).End(xlToRight))
        With .Borders
            .LineStyle = xlContinuous
            .Weight = xlThin
            .ColorIndex = xlAutomatic
        End With
        .Borders(xlEdgeBottom).Weight = xlMedium
    End With
    With Range("A6:D6")
        With .Borders
            .LineStyle = xlContinuous
            .Weight = xlThin
            .ColorIndex = xlAutomatic
        End With
        .Borders(xlEdgeTop).Weight = xlMedium
        .Borders(xlEdgeBottom).Weight = xlMedium
    End With
    For Counter1 = 1 To nBlock - 1
        With Range(Cells(TotalReps * Counter1 + 7, 1), Cells(TotalReps * Counter1 + 7, 4)).Borders(xlEdgeTop)
            .LineStyle = xlContinuous
            .Weight = xlMedium
            .ColorIndex = xlAutomatic
        End With
    Next Counter1
    
' Layout sheet
    Worksheets("Design, layout").Activate
    Columns.ColumnWidth = 8.43
    Range("A3") = "x"
    Range("A3", Range("A3").SpecialCells(xlLastCell)).EntireRow.Delete
    Range("B1") = "x"
    Range("B1", Range("B1").SpecialCells(xlLastCell)).EntireColumn.Delete
    Worksheets("Design, list").Activate
    Range("A3", Range("A3").SpecialCells(xlLastCell)).Copy
    Worksheets("Design, layout").Activate
    Range("A3").PasteSpecial xlPasteAll
    Cells.Borders.LineStyle = xlNone

    For Counter1 = 1 To nBlock
        Cells(7, Counter1 + 4) = Counter1
        For Counter2 = 1 To TotalReps
            Cells(Counter2 + 7, Counter1 + 4) = _
                Cells((Counter1 - 1) * TotalReps + Counter2 + 6, 3)
        Next Counter2
    Next Counter1
    Range("B6", Cells(TotalReps + 6, 2)).Copy
    Range("D7").PasteSpecial xlPasteValues
    Range("D6") = Range("C6")
    Range("D6", Range("D7").End(xlToRight)).Font.Bold = True
    For Counter1 = 1 To nBlock + 1
        Range("D1").Offset(0, Counter1 - 1).EntireColumn.AutoFit
    Next Counter1
    For Counter1 = 1 To nBlock + 1
        Range("A1").Offset(0, Counter1 - 1).Columns("A:A").ColumnWidth = _
            Range("D1").Offset(0, Counter1 - 1).Columns("A:A").ColumnWidth + 6
    Next Counter1
    Range("E6") = Range("A6")
    Range("C6", Range("C6").End(xlDown).End(xlToLeft)).ClearContents
    Range("A6") = Range("D6")
    Range("B6") = Range("E6")
    For Counter1 = 1 To nBlock + 1
        For Counter2 = 1 To TotalReps + 1
            Cells(Counter2 + 6, Counter1) = Cells(Counter2 + 6, Counter1 + 3)
        Next Counter2
    Next Counter1
    Range("D6", Range("D6").End(xlToRight)).ClearContents
    Counter2 = Application.WorksheetFunction.Max(nBlock, 3)
    For Counter1 = 1 To Counter2
        Cells(5, nBlock + 2).Offset(0, Counter1 - 1).Columns("A:A").ColumnWidth = 8.43
    Next Counter1
    Range(Cells(5, nBlock + 2), Cells(5, nBlock + 2).SpecialCells(xlLastCell)).Delete
    Range(Cells(TotalReps + 8, 1), Cells(nTreat + 8, 1).SpecialCells(xlLastCell)).Delete
    Cells(TotalReps + 8, nBlock + 2) = "x"
    Range(Cells(TotalReps + 8, nBlock + 2), Cells(TotalReps + 8, nBlock + 2).SpecialCells(xlLastCell)).EntireRow.Delete
    Cells(TotalReps + 8, nBlock + 2) = "x"
    Range(Cells(TotalReps + 8, nBlock + 2), Cells(TotalReps + 8, nBlock + 2).SpecialCells(xlLastCell)).EntireColumn.Delete
    Range("A7", Range("A7").End(xlToRight)).Font.Bold = True
    Range("A6:B6").HorizontalAlignment = xlLeft
    Range("A7", Range("A7").End(xlDown).End(xlToRight)).HorizontalAlignment = xlCenter
    With Range("B8", Range("B8").End(xlDown).End(xlToRight))
        With .Borders
            .LineStyle = xlContinuous
            .Weight = xlThin
            .ColorIndex = xlAutomatic
        End With
        .Borders(xlEdgeBottom).Weight = xlMedium
    End With
    With Range("A7", Range("A7").End(xlDown))
        With .Borders
            .LineStyle = xlContinuous
            .Weight = xlThin
            .ColorIndex = xlAutomatic
        End With
        .Borders(xlEdgeBottom).Weight = xlMedium
        .Borders(xlEdgeRight).Weight = xlMedium
    End With
    With Range("A7", Range("A7").End(xlToRight))
        .Font.Bold = True
        With .Borders
            .LineStyle = xlContinuous
            .Weight = xlThin
            .ColorIndex = xlAutomatic
        End With
        .Borders(xlEdgeBottom).Weight = xlMedium
        .Borders(xlEdgeTop).Weight = xlMedium
    End With
    With Range("A7").Borders(xlEdgeRight)
            .LineStyle = xlContinuous
            .Weight = xlMedium
            .ColorIndex = xlAutomatic
    End With
    With ActiveSheet.PageSetup
        .PrintTitleRows = "$2:$7"
        .PrintTitleColumns = ""
        .CenterFooter = "Page &P of &N"
    End With
    Range("D1").Select
    With ActiveWindow
        .ScrollRow = 1
        .ScrollColumn = 1
    End With
    
' Terminate
    Worksheets("Design, list").Activate
    With ActiveSheet.PageSetup
        .PrintTitleRows = "$2:$6"
        .PrintTitleColumns = ""
        .CenterFooter = "Page &P of &N"
    End With
    Sheets("Design, list").Range("D1").Select
    With ActiveWindow
        .ScrollRow = 1
        .ScrollColumn = 1
    End With
    Application.ScreenUpdating = True
    Response = MsgBox("Now save this spreadsheet!", 0, "Edgar II")
    
    Else
        Application.ScreenUpdating = True
    End If

End Sub
Sub SuddenStop()
    Application.ScreenUpdating = True
    ActiveWindow.LargeScroll Down:=1
    ActiveWindow.LargeScroll Up:=1
    NoWorries = False
End Sub


============================================================
--- ThisWorkbook.cls ---
============================================================
Attribute VB_Name = "ThisWorkbook"
Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = True


============================================================
--- Sheet2.cls ---
============================================================
Attribute VB_Name = "Sheet2"
Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = True



============================================================
--- Sheet1.cls ---
============================================================
Attribute VB_Name = "Sheet1"
Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = True


============================================================
--- Sheet3.cls ---
============================================================
Attribute VB_Name = "Sheet3"
Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = True

