夷陵网_昆山网站建设电话_百度信息流_seo外包靠谱

在品比试验大家多使用间比法试验设计，这里通过excel VBA实现间比法设计，代码如下：

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 IntegerApplication.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 = "是" ThenRandomize ' 初始化随机数生成器For m = LBound(arr) To UBound(arr) - 1n = Int((UBound(arr) - m + 1) * Rnd + m)' 交换元素tmp = arr(m, 1)arr(m, 1) = arr(n, 1)arr(n, 1) = tmpNext m
End IfIf 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 Thenc_num = Int(t_num / row_num) + 1'将含有对照的品种信息列入新数组中r = 1s = 1For i = 1 To c_num - 1For j = 1 To row_numarr2(r, 1) = iarr2(r, 2) = jarr2(r, 3) = rIf r Mod (var_num + 1) = 1 Thenarr2(r, 4) = ckr = r + 1Elsearr2(r, 4) = arr(s, 1)r = r + 1s = s + 1End IfNextNextFor j = 1 To (t_num Mod row_num)arr2(r, 1) = c_numarr2(r, 2) = jarr2(r, 3) = rIf r Mod (var_num + 1) = 1 Thenarr2(r, 4) = ckr = r + 1Elsearr2(r, 4) = arr(s, 1)r = r + 1s = s + 1End IfNextElsec_num = Int(t_num / row_num)'将含有对照的品种信息列入新数组中r = 1s = 1For i = 1 To c_numFor j = 1 To row_numarr2(r, 1) = iarr2(r, 2) = jarr2(r, 3) = rIf r Mod 10 = 1 Thenarr2(r, 4) = ckr = r + 1Elsearr2(r, 4) = arr(s, 1)r = r + 1s = s + 1End IfNextNextEnd IfElse'常规法设置对照'确定单排ck数量If (row_num - 1) Mod (var_num + 1) Thenck_num = 1 + Int((row_num - 1) / (var_num + 1)) + 1Elseck_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) Thenc_num = c_num + 1t_num = (lastRow - 1) + (c_num - 1) * ck_numIf (lastRow - 1 - (c_num - 1) * (row_num - ck_num)) Mod var_num Thent_num = t_num + 1 + Int((lastRow - 1 - (c_num - 1) * (row_num - ck_num)) / var_num) + 1Elset_num = t_num + 1 + Int((lastRow - 1 - (c_num - 1) * (row_num - ck_num)) / var_num)End IfElsec_num = c_numt_num = (lastRow - 1) + c_num * ck_numEnd If'设置排区号的数组ReDim arr2(1 To t_num, 1 To 4) As Variant'确定排数，并将含有对照的品种名称列入新的数组中If t_num Mod row_num Thenc_num = Int(t_num / row_num) + 1'将含有对照的品种信息列入新数组中r = 1s = 1For i = 1 To c_num - 1For j = 1 To row_numarr2(r, 1) = iarr2(r, 2) = jarr2(r, 3) = rIf j Mod (var_num + 1) = 1 Thenarr2(r, 4) = ckr = r + 1ElseIf j = row_num Thenarr2(r, 4) = ckr = r + 1Elsearr2(r, 4) = arr(s, 1)r = r + 1s = s + 1End IfNextNextFor j = 1 To (t_num Mod row_num)arr2(r, 1) = c_numarr2(r, 2) = jarr2(r, 3) = rIf j Mod (var_num + 1) = 1 Thenarr2(r, 4) = ckr = r + 1ElseIf j = (t_num Mod row_num) Thenarr2(r, 4) = ckr = r + 1Elsearr2(r, 4) = arr(s, 1)r = r + 1s = s + 1End IfNextElsec_num = Int(t_num / row_num)'将含有对照的品种信息列入新数组中r = 1s = 1For i = 1 To c_numFor j = 1 To row_numarr2(r, 1) = iarr2(r, 2) = jarr2(r, 3) = rIf j Mod (var_num + 1) = 1 Thenarr2(r, 4) = ckr = r + 1ElseIf j = row_num Thenarr2(r, 4) = ckr = r + 1Elsearr2(r, 4) = arr(s, 1)r = r + 1s = s + 1End IfNextNextEnd IfEnd If'对数组进行之字排列
If pl2 = "之字" Thenarr2 = zhizi(arr2, t_num, row_num, c_num)
End If' 新建一个工作表，用于生成带有排区号的整列数据
Set ws = ThisWorkbook.Sheets.Add
If sn <> "" Thenws.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 + 1For j = 1 To 4ws.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.Countarr5(i - 1) = CStr(rng(i, 1)) & " " & CStr(rng(i, 2))arr6(i - 1) = rng(i, 4)
NextIf pl = "纵向" Then'输入列号j = 1For i = col_min To col_maxws.Cells(1, j + 7).Value = ij = j + 1Next'输入行号j = 1For i = row_min To row_maxws.Cells(j + 1, 7).Value = ij = j + 1Next'将品种名称放入对应行排号的单元格中For i = 8 To col_max - col_min + 8For j = 2 To row_max - row_min + 2ws.Cells(j, i).Value = WorksheetFunction.XLookup(CStr(ws.Cells(1, i)) & " " & CStr(ws.Cells(j, 7)), arr5, arr6, "空", 0, 1)NextNextElse'输入行号j = 1For i = row_min To row_maxws.Cells(1, j + 7).Value = ij = j + 1Next'输入列号j = 1For i = col_min To col_maxws.Cells(j + 1, 7).Value = ij = j + 1Next'将品种名称放入对应行排号的单元格中For i = 8 To row_max - row_min + 8For j = 2 To col_max - col_min + 2ws.Cells(j, i).Value = WorksheetFunction.XLookup(CStr(ws.Cells(j, 7)) & " " & CStr(ws.Cells(1, i)), arr5, arr6, "空", 0, 1)NextNextEnd IfApplication.ScreenUpdating = True       '刷新屏幕开启
Application.DisplayAlerts = True        '警告提示框开启End SubSub biankuang(ws As Worksheet, rng As Range)'边框和居中设置子程序'对单元格进行居中设置ws.Cells(1, 1).CurrentRegion().HorizontalAlignment = xlCenterws.Cells(1, 1).VerticalAlignment = xlCenter'对田间种植区域添加边框With rng.Borders.LineStyle = xlContinuous.Weight = xlThin.Color = RGB(0, 0, 0) ' 黑色End With
End SubFunction zhizi(arr As Variant, t_num As Integer, row_num As Integer, c_num As Integer)'zhizi即“之字”,之字排列函数Dim arr3 As VariantDim i_z As Integer, j_z As IntegerReDim arr3(1 To t_num, 1 To 4) As VariantFor i_z = 1 To t_numIf arr(i_z, 1) Mod 2 Thenarr3(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)Elsearr3(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 IfNextzhizi = arr3
End Function

设置界面如下：