一个可以自动生成随机区组试验的excel VBA小程序2
本程序用于应对随机区组试验中要求相同小区位置不能出现同一品种的情况。编程思路略有不同，故将另开一篇。
（）
本试验设计是在原来的基础上改版的，相关的参数设置与操作同上一版，这里不在赘述：一个可以自动生成随机区组试验的excel VBA小程序-CSDN博客
实现代码如下：
（）
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, k As Integer
Dim arr As Variant, rngValues As Variant, tmp As Variant
Application.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 "" Then
ws.Name = sn ' 将新工作表的名称设置为"新工作表"
End If
' 将范围内的值存储在数组中
rngValues = rng.Value
ReDim arr(1 To UBound(rngValues), 1 To qz_num) As Variant
For i = 1 To qz_num
For j = 1 To (lastRow - 1) '对数组进行赋值
arr(j, i) = rngValues(j, 1)
Next
Next
For i = 1 To qz_num ' 随机排列数组中的元素
rnd:
Randomize ' 初始化随机数生成器
For m = LBound(arr) To UBound(arr) - 1
n = Int((UBound(arr) - m + 1) * rnd + m)
' 交换元素
tmp = arr(m, i)
arr(m, i) = arr(n, i)
arr(n, i) = tmp
Next m
If i 1 Then
For k = 1 To (i - 1)
For j = 1 To (lastRow - 1)
If arr(j, k) = arr(j, i) Then
GoTo rnd
End If
Next
Next
End If
Next
If pq = "否" Then '没有排区号的情况
Select Case pl
Case "横向"
'输入行标题
For i = 1 To qz_num
ws.Cells(i, 1).Value = "区组" & i
Next
'将品种名称放入对应行排号的单元格中
For j = 1 To qz_num '对行号循环
For i = 2 To lastRow '对列号循环
ws.Cells(j, i).Value = arr(i - 1, j)
Next
Next
Set rng2 = Range(ws.Cells(1, 1), ws.Cells(j - 1, i - 1))
'对单元格进行居中设置
ws.Cells(1, 1).CurrentRegion().HorizontalAlignment = xlCenter
ws.Cells(1, 1).VerticalAlignment = xlCenter
'对田间种植区域添加边框
With rng2.Borders
.LineStyle = xlContinuous
.Weight = xlThin
.Color = RGB(0, 0, 0) ' 黑色
End With
Case "纵向"
'输入列标题
For i = 1 To qz_num
ws.Cells(1, i).Value = "区组" & i
Next
'将品种名称放入对应行排号的单元格中
For j = 1 To qz_num '对列号循环
For i = 2 To lastRow '对行号循环
ws.Cells(i, j).Value = arr(i - 1, j)
Next
Next
Set rng2 = Range(ws.Cells(1, 1), ws.Cells(i - 1, j - 1))
'对单元格进行居中设置
ws.Cells(1, 1).CurrentRegion().HorizontalAlignment = xlCenter
ws.Cells(1, 1).VerticalAlignment = xlCenter
'对田间种植区域添加边框
With rng2.Borders
.LineStyle = xlContinuous
.Weight = xlThin
.Color = RGB(0, 0, 0) ' 黑色
End With
Case Else
MsgBox "无此排列类型，请重新选择"
End Select
Else '有排区号的情况
Select Case pl
Case "横向"
'输入行标题
For i = 1 To qz_num * 2 Step 2
ws.Cells(i, 1).Value = "排区号"
Next
For i = 2 To qz_num * 2 Step 2
ws.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)
Next
Else '对行号进行判断，若为偶数则输入品种名称
For i = 2 To lastRow '对列号循环
ws.Cells(j, i).Value = arr(i - 1, (Int(j / 2)))
Next
End If
Next
Set rng2 = Range(ws.Cells(1, 1), ws.Cells(j - 1, i - 1))
'对单元格进行居中设置
ws.Cells(1, 1).CurrentRegion().HorizontalAlignment = xlCenter
ws.Cells(1, 1).VerticalAlignment = xlCenter
'对田间种植区域添加边框
With rng2.Borders
.LineStyle = xlContinuous
.Weight = xlThin
.Color = RGB(0, 0, 0) ' 黑色
End With
Case "纵向"
'输入列标题
For i = 1 To qz_num * 2 Step 2
ws.Cells(1, i).Value = "排区号"
Next
For i = 2 To qz_num * 2 Step 2
ws.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)
Next
Else '对列号进行判断，若为偶数则输入品种名称
For i = 2 To lastRow '对列号循环
ws.Cells(i, j).Value = arr(i - 1, (Int(j / 2)))
Next
End If
Next
Set rng2 = Range(ws.Cells(1, 1), ws.Cells(i - 1, j - 1))
'对单元格进行居中设置
ws.Cells(1, 1).CurrentRegion().HorizontalAlignment = xlCenter
ws.Cells(1, 1).VerticalAlignment = xlCenter
'对田间种植区域添加边框
With rng2.Borders
.LineStyle = xlContinuous
.Weight = xlThin
.Color = RGB(0, 0, 0) ' 黑色
End With
Case Else
MsgBox "无此排列类型，请重新选择"
End Select
End If
Application.ScreenUpdating = True '刷新屏幕开启
Application.DisplayAlerts = True '警告提示框开启
End Sub
免责声明：我们致力于保护作者版权，注重分享，被刊用文章因无法核实真实出处，未能及时与作者取得联系，或有版权异议的，请联系管理员，我们会立即处理!
部分文章是来自自研大数据AI进行生成,内容摘自(百度百科,百度知道,头条百科,中国民法典,刑法,牛津词典,新华词典,汉语词典,国家院校,科普平台)等数据,内容仅供学习参考,不准确地方联系删除处理!
图片声明：本站部分配图来自人工智能系统AI生成,觅知网授权图片,PxHere摄影无版权图库和百度，360，搜狗等多加搜索引擎自动关键词搜索配图，如有侵权的图片，请第一时间联系我们，邮箱：ciyunidc@ciyunshuju.com。本站只作为美观性配图使用,无任何非法侵犯第三方意图,一切解释权归图片著作权方,本站不承担任何责任。如有恶意碰瓷者,必当奉陪到底严惩不贷!
