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

前面编写了一个：一个可以自动生成随机区组试验的excel VBA小程序2_excel进行区组试验设计-CSDN博客

根据同行的最新要求，调整有以下功能：

1、对照品种不能位于边行

2、同一品种不能出现在同一行（小区）

3、按试点生成随机区组设计，且决定是否汇总到一个表里

        具体说明如下：

1、当A2单元格选择为是，则按试点自动生成一个汇总表

实现内容如下：

2、当A14单元格设置为“品种1”时即对照为品种1，则在边行不出现品种1。

实现内容如下：

实现VBA代码如下：

Sub 生成试验设计()

Dim ws As Worksheet, tg_ws As Worksheet
Dim rng As Range, rng2 As Range, loc_rng 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, lastRow_2 As Integer, loc_i As Integer
Dim m As Integer, n As Integer, k As Integer, qz_i As Integer
Dim multi_tab As String
Dim arr As Variant, rngValues As Variant, tmp As Variant
Dim ck_name As String

Dim ws_i As Worksheet   '工作表合并用
Dim targetSheet As Worksheet    '工作表合并用
Dim lastRow_A As Long   '工作表合并用
Dim wsi As Integer  '工作表合并用

Application.ScreenUpdating = False       '刷新屏幕关闭
Application.DisplayAlerts = False        '警告提示框关闭



'获取初始设置
pq = Range("A5").Value   '是否包含排区号
pl = Range("A8").Value    '试验设计是横向排列还是纵向排列
qz_num = Range("A11").Value    '区组的数量
multi_tab = Range("A2").Value    '试验点数量
ck_name = Range("A14").Value  '对照品种名称


'获取品种名称
lastRow = Range("C10000").End(xlUp).Row    '获取品种名称列的最后一行的行号
Set rng = Range("C2:C" & lastRow)

'获取试点名称
lastRow_2 = Range("E10000").End(xlUp).Row    '获取品种名称列的最后一行的行号
Set loc_rng = Range("E2:E" & lastRow_2)


'按试验点数量进行循环
For loc_i = 1 To (lastRow_2 - 1)

    ' 新建一个工作表，用于生成随机区组试验设计
    Set ws = ThisWorkbook.Sheets.Add
    ws.Name = loc_rng(loc_i).Value     ' 将新工作表的名称设置为试点名称
    
    ' 将范围内的值存储在数组中
    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 arr(1, i) = ck_name Then GoTo rnd
        If arr(lastRow - 1, i) = ck_name Then GoTo rnd
        
        ' 要求同一个品种不出现在同一行（小区）
        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
Next

If multi_tab = "是" Then
    Set targetSheet = ThisWorkbook.Sheets.Add
    targetSheet.Name = "汇总"
    
    ' 初始化行号
    lastRow_A = targetSheet.Cells(targetSheet.Rows.Count, 1).End(xlUp).Row + 1
    
    ' 遍历所有工作表
    For wsi = 1 To ThisWorkbook.Sheets.Count
        Set ws_i = ThisWorkbook.Sheets(wsi)
        
        ' 跳过目标工作表本身和汇总工作表本身（如果它们是单独的工作表）
        If ws_i.Name <> targetSheet.Name And ws_i.Name <> "随机区组设计" Then
            ' 复制数据到目标工作表的指定位置，并调整位置
            targetSheet.Cells(lastRow_A, 1).Value = ws_i.Name
            ws_i.UsedRange.Copy Destination:=targetSheet.Cells(lastRow_A + 1, 1)
            lastRow_A = targetSheet.Cells(targetSheet.Rows.Count, 1).End(xlUp).Row + ws_i.UsedRange.Rows.Count
        End If
    Next
    
    ' 可选：调整列宽以适应内容
    targetSheet.Columns.AutoFit
End If


Application.ScreenUpdating = True       '刷新屏幕开启
Application.DisplayAlerts = True        '警告提示框开启

End Sub