在品比试验大家多使用间比法试验设计，这里通过excel VBA实现间比法设计，代码如下：
vbscript
Sub 生成试验设计()
Dim ws As Worksheet
Dim rng As Range, rng2 As Range, rng3 As Range
Dim cell As Range, lastcell As Range
Dim rd As String, sn As String, pl As String 'rd为是否随机排列品种顺序,sn即sheetname的简称,pl即排在sheet表中的方向的简称
Dim ck As String, var_num As Integer, pl2 As String, method As String ' method即对照设置方法，var_num即对照间品种数量，pl2即品种在每排的排列方式
Dim row_num As Integer '每排行数
Dim i As Integer, j As Integer, r As Integer, s As Integer, m As Integer, n As Integer, lastRow As Integer
Dim t_num As Integer, c_num As Integer, ck_num As Integer 't_num为加上对照后总的品种数，c_num为总列数
Dim arr As Variant, arr2 As Variant, rngValues As Variant, tmp As Variant
Dim arr5 As Variant, arr6 As Variant
Dim col_min As Integer, col_max As Integer, row_min As Integer, row_max As Integer
Application.ScreenUpdating = False '刷新屏幕关闭
Application.DisplayAlerts = False '警告提示框关闭
'获取初始设置
sn = Range("A2").Value '新建工作表的名称
rd = Range("A5").Value '是否随机排列品种顺序
pl = Range("A8").Value '试验设计是横向排列还是纵向排列
row_num = Range("A11").Value '每排行数
pl2 = Range("A14").Value '品种在排之间的排列方式
method = Range("A17").Value '对照的设置方法
var_num = Range("A20").Value '对照间品种的间隔数
ck = Range("A23").Value '设置对照名称，默认为"CK"
'获取品种名称
lastRow = Range("C10000").End(xlUp).Row '获取品种名称列的最后一行的行号
Set rng = Range("C2:C" & lastRow)
' 将范围内的值存储在数组中
rngValues = rng.Value
ReDim arr(UBound(rngValues)) As Variant
arr = rngValues
' 随机排列数组中的元素
If rd = "是" Then
Randomize ' 初始化随机数生成器
For m = LBound(arr) To UBound(arr) - 1
n = Int((UBound(arr) - m + 1) * Rnd + m)
' 交换元素
tmp = arr(m, 1)
arr(m, 1) = arr(n, 1)
arr(n, 1) = tmp
Next m
End If
If method = "逢X法" Then
'确定包含对照的总品种数量
t_num = lastRow - 1 + Int((lastRow - 1) / (var_num))
'设置排区号的数组
ReDim arr2(1 To t_num, 1 To 4) As Variant
'确定排数，并将含有对照的品种名称列入新的数组中
If t_num Mod row_num Then
c_num = Int(t_num / row_num) + 1
'将含有对照的品种信息列入新数组中
r = 1
s = 1
For i = 1 To c_num - 1
For j = 1 To row_num
arr2(r, 1) = i
arr2(r, 2) = j
arr2(r, 3) = r
If r Mod (var_num + 1) = 1 Then
arr2(r, 4) = ck
r = r + 1
Else
arr2(r, 4) = arr(s, 1)
r = r + 1
s = s + 1
End If
Next
Next
For j = 1 To (t_num Mod row_num)
arr2(r, 1) = c_num
arr2(r, 2) = j
arr2(r, 3) = r
If r Mod (var_num + 1) = 1 Then
arr2(r, 4) = ck
r = r + 1
Else
arr2(r, 4) = arr(s, 1)
r = r + 1
s = s + 1
End If
Next
Else
c_num = Int(t_num / row_num)
'将含有对照的品种信息列入新数组中
r = 1
s = 1
For i = 1 To c_num
For j = 1 To row_num
arr2(r, 1) = i
arr2(r, 2) = j
arr2(r, 3) = r
If r Mod 10 = 1 Then
arr2(r, 4) = ck
r = r + 1
Else
arr2(r, 4) = arr(s, 1)
r = r + 1
s = s + 1
End If
Next
Next
End If
Else
'常规法设置对照
'确定单排ck数量
If (row_num - 1) Mod (var_num + 1) Then
ck_num = 1 + Int((row_num - 1) / (var_num + 1)) + 1
Else
ck_num = 1 + Int((row_num - 1) / (var_num + 1))
End If
'确定总排数和含对照的总品种数量
c_num = Int((lastRow - 1) / (row_num - ck_num))
If (lastRow - 1) Mod (row_num - ck_num) Then
c_num = c_num + 1
t_num = (lastRow - 1) + (c_num - 1) * ck_num
If (lastRow - 1 - (c_num - 1) * (row_num - ck_num)) Mod var_num Then
t_num = t_num + 1 + Int((lastRow - 1 - (c_num - 1) * (row_num - ck_num)) / var_num) + 1
Else
t_num = t_num + 1 + Int((lastRow - 1 - (c_num - 1) * (row_num - ck_num)) / var_num)
End If
Else
c_num = c_num
t_num = (lastRow - 1) + c_num * ck_num
End If
'设置排区号的数组
ReDim arr2(1 To t_num, 1 To 4) As Variant
'确定排数，并将含有对照的品种名称列入新的数组中
If t_num Mod row_num Then
c_num = Int(t_num / row_num) + 1
'将含有对照的品种信息列入新数组中
r = 1
s = 1
For i = 1 To c_num - 1
For j = 1 To row_num
arr2(r, 1) = i
arr2(r, 2) = j
arr2(r, 3) = r
If j Mod (var_num + 1) = 1 Then
arr2(r, 4) = ck
r = r + 1
ElseIf j = row_num Then
arr2(r, 4) = ck
r = r + 1
Else
arr2(r, 4) = arr(s, 1)
r = r + 1
s = s + 1
End If
Next
Next
For j = 1 To (t_num Mod row_num)
arr2(r, 1) = c_num
arr2(r, 2) = j
arr2(r, 3) = r
If j Mod (var_num + 1) = 1 Then
arr2(r, 4) = ck
r = r + 1
ElseIf j = (t_num Mod row_num) Then
arr2(r, 4) = ck
r = r + 1
Else
arr2(r, 4) = arr(s, 1)
r = r + 1
s = s + 1
End If
Next
Else
c_num = Int(t_num / row_num)
'将含有对照的品种信息列入新数组中
r = 1
s = 1
For i = 1 To c_num
For j = 1 To row_num
arr2(r, 1) = i
arr2(r, 2) = j
arr2(r, 3) = r
If j Mod (var_num + 1) = 1 Then
arr2(r, 4) = ck
r = r + 1
ElseIf j = row_num Then
arr2(r, 4) = ck
r = r + 1
Else
arr2(r, 4) = arr(s, 1)
r = r + 1
s = s + 1
End If
Next
Next
End If
End If
'对数组进行之字排列
If pl2 = "之字" Then
arr2 = zhizi(arr2, t_num, row_num, c_num)
End If
' 新建一个工作表，用于生成带有排区号的整列数据
Set ws = ThisWorkbook.Sheets.Add
If sn <> "" Then
ws.Name = sn ' 将新工作表的名称设置为"新工作表"
End If
'工作表内数据录入
ws.Cells(1, 1).Value = "排号"
ws.Cells(1, 2).Value = "行号"
ws.Cells(1, 3).Value = "序号"
ws.Cells(1, 4).Value = "品种名称"
For i = 2 To t_num + 1
For j = 1 To 4
ws.Cells(i, j).Value = arr2(i - 1, j)
Next
Next
'设置格式
Set rng2 = Range(ws.Cells(1, 1), ws.Cells(i - 1, j - 1))
'对单元格进行居中设置,添加边框
Call biankuang(ws, rng2)
Set rng = ws.Range("A1").CurrentRegion
col_max = WorksheetFunction.Max(ws.Range("A2:A" & (rng.Rows.Count)))
col_min = WorksheetFunction.Min(ws.Range("A2:A" & (rng.Rows.Count)))
row_max = WorksheetFunction.Max(ws.Range("B2:B" & (rng.Rows.Count)))
row_min = WorksheetFunction.Min(ws.Range("B2:B" & (rng.Rows.Count)))
'将行排号和品种名称放入数组，用于xlookup查询
ReDim arr5(1 To rng.Rows.Count - 1)
ReDim arr6(1 To rng.Rows.Count - 1)
For i = 2 To rng.Rows.Count
arr5(i - 1) = CStr(rng(i, 1)) & " " & CStr(rng(i, 2))
arr6(i - 1) = rng(i, 4)
Next
If pl = "纵向" Then
'输入列号
j = 1
For i = col_min To col_max
ws.Cells(1, j + 7).Value = i
j = j + 1
Next
'输入行号
j = 1
For i = row_min To row_max
ws.Cells(j + 1, 7).Value = i
j = j + 1
Next
'将品种名称放入对应行排号的单元格中
For i = 8 To col_max - col_min + 8
For j = 2 To row_max - row_min + 2
ws.Cells(j, i).Value = WorksheetFunction.XLookup(CStr(ws.Cells(1, i)) & " " & CStr(ws.Cells(j, 7)), arr5, arr6, "空", 0, 1)
Next
Next
Else
'输入行号
j = 1
For i = row_min To row_max
ws.Cells(1, j + 7).Value = i
j = j + 1
Next
'输入列号
j = 1
For i = col_min To col_max
ws.Cells(j + 1, 7).Value = i
j = j + 1
Next
'将品种名称放入对应行排号的单元格中
For i = 8 To row_max - row_min + 8
For j = 2 To col_max - col_min + 2
ws.Cells(j, i).Value = WorksheetFunction.XLookup(CStr(ws.Cells(j, 7)) & " " & CStr(ws.Cells(1, i)), arr5, arr6, "空", 0, 1)
Next
Next
End If
Application.ScreenUpdating = True '刷新屏幕开启
Application.DisplayAlerts = True '警告提示框开启
End Sub
Sub biankuang(ws As Worksheet, rng As Range)
'边框和居中设置子程序
'对单元格进行居中设置
ws.Cells(1, 1).CurrentRegion().HorizontalAlignment = xlCenter
ws.Cells(1, 1).VerticalAlignment = xlCenter
'对田间种植区域添加边框
With rng.Borders
.LineStyle = xlContinuous
.Weight = xlThin
.Color = RGB(0, 0, 0) ' 黑色
End With
End Sub
Function zhizi(arr As Variant, t_num As Integer, row_num As Integer, c_num As Integer)
'zhizi即"之字",之字排列函数
Dim arr3 As Variant
Dim i_z As Integer, j_z As Integer
ReDim arr3(1 To t_num, 1 To 4) As Variant
For i_z = 1 To t_num
If arr(i_z, 1) Mod 2 Then
arr3(i_z, 1) = arr(i_z, 1)
arr3(i_z, 2) = arr(i_z, 2)
arr3(i_z, 3) = arr(i_z, 3)
arr3(i_z, 4) = arr(i_z, 4)
Else
arr3(i_z, 1) = arr(i_z, 1)
arr3(i_z, 2) = arr(row_num - arr(i_z, 2) + 1, 2)
arr3(i_z, 3) = arr(i_z, 3)
arr3(i_z, 4) = arr(i_z, 4)
End If
Next
zhizi = arr3
End Function设置界面如下：
参数说明：
1、是否随机排列：是对上图右侧品种顺序是否进行随机排列，如果选择将将随机排列，如果选择否，将按照给定的顺序排列
2、表格中的排列方向：若选择横向，则以行为排；若选择纵向，则以列为排
3、每排的行数：这里的行数是指田间的小区数。
4、排列方式：分为顺序排列和"之字"型配列。
5、对照设置：逢X法，即在1的位置放置对照，后面每间隔固定长度设置一个对照；常规法，即在一排的首尾设置对照，并且在一排内间隔固定长度设置一个对照
6、对照间隔数：即两个对照品种之间间隔的小区数量。
7、对照名称：默认为CK，也可以设置为具体的名称。
图1：不随机排列，排列方向横向，每排11行，之字排列，常规法设置对照
图2：不随机排列，排列方向横向，每排10行，之字排列，逢X法设置对照
图3：不随机排列，纵向，每排15行，之字排列，逢X法
图4：随机，纵向，顺序排列，每排11行，常规法设置对照，对照间隔为4行
