当前位置：首页 > news >正文

一个可以自动生成随机区组试验的excel VBA小程序

news 来源：原创 2024/9/29 13:21:17

在作物品种区域试验时，通常会采用随机区组试验设计，特制作了一个可以自动生成随机区组试验的小程序。excel参数界面如下：

参数含义如下：

1、生成新表的名称：程序将新建表格，用于生成随机区组试验。若此处为空，则为系统默认的新建表格名称，若含有名称，则新建表以此名称命名。

2、是否含排区号：若选择“是”，则以“1-1”的形式显示第几排，第几个小区。若选择“否”，则不显示，仅在标题处显示区组名称。

3、区组内品种排列方向：若为“横向”，则表格中在同一行中排列一个区组的不同品种；如选择“纵向”，则表格中在同一列中排列一个区组的不同品种。

4、区组数量：表示需要设置的区组数量，通常为3。

以上图中默认的设置运行代码，显示结果如下：

具体实现代码如下：

Sub 生成试验设计()Dim ws As Worksheet, tg_ws As Worksheet
Dim rng As Range, rng2 As Range
Dim cell As Range, lastcell As Range
Dim pq As String, sn As String, pl As String   'pq即排区号的简称,sn即sheetname的简称,pl即排列的简称
Dim qz_num As Integer
Dim i As Integer, j As Integer, lastRow As Integer
Dim m As Integer, n As Integer
Dim arr As Variant, rngValues As Variant, tmp As VariantApplication.ScreenUpdating = False       '刷新屏幕关闭
Application.DisplayAlerts = False        '警告提示框关闭'获取初始设置
sn = Range("A2").Value    '新建工作表的名称
pq = Range("A5").Value   '是否包含排区号
pl = Range("A8").Value    '试验设计是横向排列还是纵向排列
qz_num = Range("A11").Value    '区组的数量'获取品种名称
lastRow = Range("C10000").End(xlUp).Row    '获取品种名称列的最后一行的行号
Set rng = Range("C2:C" & lastRow)' 新建一个工作表，用于生成随机区组试验设计
Set ws = ThisWorkbook.Sheets.Add
If sn <> "" Thenws.Name = sn       ' 将新工作表的名称设置为"新工作表"
End If' 将范围内的值存储在数组中
rngValues = rng.Value
ReDim arr(UBound(rngValues)) As VariantIf pq = "否" Then    '没有排区号的情况Select Case plCase "横向"'输入行标题For i = 1 To qz_numws.Cells(i, 1).Value = "区组" & iNext'将品种名称放入对应行排号的单元格中For j = 1 To qz_num    '对行号循环' 随机排列数组中的元素arr = rngValuesRandomize ' 初始化随机数生成器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 mFor i = 2 To lastRow    '对列号循环ws.Cells(j, i).Value = arr(i - 1, 1)NextNextSet rng2 = Range(ws.Cells(1, 1), ws.Cells(j - 1, i - 1))'对单元格进行居中设置ws.Cells(1, 1).CurrentRegion().HorizontalAlignment = xlCenterws.Cells(1, 1).VerticalAlignment = xlCenter'对田间种植区域添加边框With rng2.Borders.LineStyle = xlContinuous.Weight = xlThin.Color = RGB(0, 0, 0) ' 黑色End WithCase "纵向"'输入列标题For i = 1 To qz_numws.Cells(1, i).Value = "区组" & iNext'将品种名称放入对应行排号的单元格中For j = 1 To qz_num    '对列号循环' 随机排列数组中的元素arr = rngValuesRandomize ' 初始化随机数生成器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 mFor i = 2 To lastRow    '对行号循环ws.Cells(i, j).Value = arr(i - 1, 1)NextNextSet rng2 = Range(ws.Cells(1, 1), ws.Cells(i - 1, j - 1))'对单元格进行居中设置ws.Cells(1, 1).CurrentRegion().HorizontalAlignment = xlCenterws.Cells(1, 1).VerticalAlignment = xlCenter'对田间种植区域添加边框With rng2.Borders.LineStyle = xlContinuous.Weight = xlThin.Color = RGB(0, 0, 0) ' 黑色End WithCase ElseMsgBox "无此排列类型，请重新选择"End Select
Else    '有排区号的情况Select Case plCase "横向"'输入行标题For i = 1 To qz_num * 2 Step 2ws.Cells(i, 1).Value = "排区号"NextFor i = 2 To qz_num * 2 Step 2ws.Cells(i, 1).Value = "品种名称"Next'将品种名称放入对应行排号的单元格中For j = 1 To qz_num * 2  '对行号循环If j Mod 2 = 1 Then    '对行号进行判断，若为奇数则输入排区号For i = 2 To lastRow    '对列号循环ws.Cells(j, i).Value = "'" & (Int(j / 2) + 1) & "-" & (i - 1)NextElse    '对行号进行判断，若为偶数则输入品种名称' 随机排列数组中的元素arr = rngValuesRandomize ' 初始化随机数生成器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 mFor i = 2 To lastRow    '对列号循环ws.Cells(j, i).Value = arr(i - 1, 1)NextEnd IfNextSet rng2 = Range(ws.Cells(1, 1), ws.Cells(j - 1, i - 1))'对单元格进行居中设置ws.Cells(1, 1).CurrentRegion().HorizontalAlignment = xlCenterws.Cells(1, 1).VerticalAlignment = xlCenter'对田间种植区域添加边框With rng2.Borders.LineStyle = xlContinuous.Weight = xlThin.Color = RGB(0, 0, 0) ' 黑色End WithCase "纵向"'输入列标题For i = 1 To qz_num * 2 Step 2ws.Cells(1, i).Value = "排区号"NextFor i = 2 To qz_num * 2 Step 2ws.Cells(1, i).Value = "品种名称"Next'将品种名称放入对应行排号的单元格中For j = 1 To qz_num * 2  '对列号循环If j Mod 2 = 1 Then    '对列号进行判断，若为奇数则输入排区号For i = 2 To lastRow    '对列号循环ws.Cells(i, j).Value = "'" & (Int(j / 2) + 1) & "-" & (i - 1)NextElse    '对列号进行判断，若为偶数则输入品种名称' 随机排列数组中的元素arr = rngValuesRandomize ' 初始化随机数生成器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 mFor i = 2 To lastRow    '对列号循环ws.Cells(i, j).Value = arr(i - 1, 1)NextEnd IfNextSet rng2 = Range(ws.Cells(1, 1), ws.Cells(i - 1, j - 1))'对单元格进行居中设置ws.Cells(1, 1).CurrentRegion().HorizontalAlignment = xlCenterws.Cells(1, 1).VerticalAlignment = xlCenter'对田间种植区域添加边框With rng2.Borders.LineStyle = xlContinuous.Weight = xlThin.Color = RGB(0, 0, 0) ' 黑色End WithCase ElseMsgBox "无此排列类型，请重新选择"End Select
End IfApplication.ScreenUpdating = True       '刷新屏幕开启
Application.DisplayAlerts = True        '警告提示框开启End Sub