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

本程序用于应对随机区组试验中要求相同小区位置不能出现同一品种的情况。编程思路略有不同,故将另开一篇。

本试验设计是在原来的基础上改版的,相关的参数设置与操作同上一版,这里不在赘述:一个可以自动生成随机区组试验的excel VBA小程序-CSDN博客

实现代码如下:

vbscript 复制代码
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
相关推荐
Coding_Doggy2 小时前
苍穹外卖Day12 | Apache POI、导出Excel报表、HttpServletResponse、工作台
excel
D155540880582 小时前
电竞护航小程序成品搭建三角洲行动护航小程序开发俱乐部点单小程序成品游戏派单小程序定制
游戏·小程序
说私域12 小时前
兴趣电商内容数据洞察未来市场走向研究——基于开源AI智能名片链动2+1模式S2B2C商城小程序的实践
人工智能·小程序
wmsj057813 小时前
小程序图片批量保存太麻烦?用这款工具一键搞定,附工具教程!
小程序
说私域15 小时前
开源AI智能名片链动2+1模式S2B2C商城小程序服务提升复购率和转介绍率的研究
人工智能·小程序
l1t18 小时前
张泽鹏先生手搓的纯ANSI处理UTF-8与美团龙猫调用expat库读取Excel xml对比测试
xml·人工智能·excel·utf8·expat
2501_9159214321 小时前
小团队如何高效完成 uni-app iOS 上架,从分工到工具组合的实战经验
android·ios·小程序·uni-app·cocoa·iphone·webview
2501_916008891 天前
uni-app iOS 文件管理与 itools 配合实战,多工具协作的完整流程
android·ios·小程序·https·uni-app·iphone·webview
!win !1 天前
uni-app项目Tabbar实现切换icon动效
小程序·uni-app
宋辰月1 天前
微信小程序-day4
微信小程序·小程序