excel VBA进行间比法设计

在品比试验大家多使用间比法试验设计，这里通过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 Integer

Application.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 = "是" Then
    Randomize ' 初始化随机数生成器
    For m = LBound(arr) To UBound(arr) - 1
        n = Int((UBound(arr) - m + 1) * Rnd + m)
        ' 交换元素
        tmp = arr(m, 1)
        arr(m, 1) = arr(n, 1)
        arr(n, 1) = tmp
    Next m
End If

If 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 Then
        c_num = Int(t_num / row_num) + 1
        '将含有对照的品种信息列入新数组中
        r = 1
        s = 1
        For i = 1 To c_num - 1
            For j = 1 To row_num
                arr2(r, 1) = i
                arr2(r, 2) = j
                arr2(r, 3) = r
                If r Mod (var_num + 1) = 1 Then
                    arr2(r, 4) = ck
                    r = r + 1
                Else
                    arr2(r, 4) = arr(s, 1)
                    r = r + 1
                    s = s + 1
                End If
            Next
        Next
        
        For j = 1 To (t_num Mod row_num)
            arr2(r, 1) = c_num
            arr2(r, 2) = j
            arr2(r, 3) = r
            If r Mod (var_num + 1) = 1 Then
                arr2(r, 4) = ck
                r = r + 1
            Else
                arr2(r, 4) = arr(s, 1)
                r = r + 1
                s = s + 1
            End If
        Next
        
    Else
        c_num = Int(t_num / row_num)
        '将含有对照的品种信息列入新数组中
        r = 1
        s = 1
        For i = 1 To c_num
            For j = 1 To row_num
                arr2(r, 1) = i
                arr2(r, 2) = j
                arr2(r, 3) = r
                If r Mod 10 = 1 Then
                    arr2(r, 4) = ck
                    r = r + 1
                Else
                    arr2(r, 4) = arr(s, 1)
                    r = r + 1
                    s = s + 1
                End If
            Next
        Next
        
    End If

Else
    
    '常规法设置对照
    '确定单排ck数量
    If (row_num - 1) Mod (var_num + 1) Then
        ck_num = 1 + Int((row_num - 1) / (var_num + 1)) + 1
    Else
        ck_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) Then
        c_num = c_num + 1
        t_num = (lastRow - 1) + (c_num - 1) * ck_num
        If (lastRow - 1 - (c_num - 1) * (row_num - ck_num)) Mod var_num Then
            t_num = t_num + 1 + Int((lastRow - 1 - (c_num - 1) * (row_num - ck_num)) / var_num) + 1
        Else
            t_num = t_num + 1 + Int((lastRow - 1 - (c_num - 1) * (row_num - ck_num)) / var_num)
        End If
    Else
        c_num = c_num
        t_num = (lastRow - 1) + c_num * ck_num
    End If
        
    '设置排区号的数组
    ReDim arr2(1 To t_num, 1 To 4) As Variant
    
    '确定排数，并将含有对照的品种名称列入新的数组中
    If t_num Mod row_num Then
        c_num = Int(t_num / row_num) + 1
        '将含有对照的品种信息列入新数组中
        r = 1
        s = 1
        For i = 1 To c_num - 1
            For j = 1 To row_num
                arr2(r, 1) = i
                arr2(r, 2) = j
                arr2(r, 3) = r
                If j Mod (var_num + 1) = 1 Then
                    arr2(r, 4) = ck
                    r = r + 1
                ElseIf j = row_num Then
                    arr2(r, 4) = ck
                    r = r + 1
                Else
                    arr2(r, 4) = arr(s, 1)
                    r = r + 1
                    s = s + 1
                End If
            Next
        Next
        
        For j = 1 To (t_num Mod row_num)
                arr2(r, 1) = c_num
                arr2(r, 2) = j
                arr2(r, 3) = r
                If j Mod (var_num + 1) = 1 Then
                    arr2(r, 4) = ck
                    r = r + 1
                ElseIf j = (t_num Mod row_num) Then
                    arr2(r, 4) = ck
                    r = r + 1
                Else
                    arr2(r, 4) = arr(s, 1)
                    r = r + 1
                    s = s + 1
                End If
        Next
        
    Else
        c_num = Int(t_num / row_num)
        '将含有对照的品种信息列入新数组中
        r = 1
        s = 1
        For i = 1 To c_num
            For j = 1 To row_num
                arr2(r, 1) = i
                arr2(r, 2) = j
                arr2(r, 3) = r
                If j Mod (var_num + 1) = 1 Then
                    arr2(r, 4) = ck
                    r = r + 1
                ElseIf j = row_num Then
                    arr2(r, 4) = ck
                    r = r + 1
                Else
                    arr2(r, 4) = arr(s, 1)
                    r = r + 1
                    s = s + 1
                End If
            Next
        Next
        
    End If
    
    
End If

'对数组进行之字排列
If pl2 = "之字" Then
    arr2 = zhizi(arr2, t_num, row_num, c_num)
End If

' 新建一个工作表，用于生成带有排区号的整列数据
Set ws = ThisWorkbook.Sheets.Add
If sn <> "" Then
    ws.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 + 1
    For j = 1 To 4
        ws.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.Count
    arr5(i - 1) = CStr(rng(i, 1)) & " " & CStr(rng(i, 2))
    arr6(i - 1) = rng(i, 4)
Next

If pl = "纵向" Then
    '输入列号
    j = 1
    For i = col_min To col_max
        ws.Cells(1, j + 7).Value = i
        j = j + 1
    Next
    '输入行号
    j = 1
    For i = row_min To row_max
        ws.Cells(j + 1, 7).Value = i
        j = j + 1
    Next
                
    '将品种名称放入对应行排号的单元格中
    For i = 8 To col_max - col_min + 8
        For j = 2 To row_max - row_min + 2
            ws.Cells(j, i).Value = WorksheetFunction.XLookup(CStr(ws.Cells(1, i)) & " " & CStr(ws.Cells(j, 7)), arr5, arr6, "空", 0, 1)
        Next
    Next

Else
    '输入行号
    j = 1
    For i = row_min To row_max
        ws.Cells(1, j + 7).Value = i
        j = j + 1
    Next
    '输入列号
    j = 1
    For i = col_min To col_max
        ws.Cells(j + 1, 7).Value = i
        j = j + 1
    Next
                
    '将品种名称放入对应行排号的单元格中
    For i = 8 To row_max - row_min + 8
        For j = 2 To col_max - col_min + 2
            ws.Cells(j, i).Value = WorksheetFunction.XLookup(CStr(ws.Cells(j, 7)) & " " & CStr(ws.Cells(1, i)), arr5, arr6, "空", 0, 1)
        Next
    Next
    
End If





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

End Sub


Sub biankuang(ws As Worksheet, rng As Range)
    '边框和居中设置子程序
    '对单元格进行居中设置
    ws.Cells(1, 1).CurrentRegion().HorizontalAlignment = xlCenter
    ws.Cells(1, 1).VerticalAlignment = xlCenter
    '对田间种植区域添加边框
    With rng.Borders
        .LineStyle = xlContinuous
        .Weight = xlThin
        .Color = RGB(0, 0, 0) ' 黑色
    End With
End Sub

Function zhizi(arr As Variant, t_num As Integer, row_num As Integer, c_num As Integer)
    'zhizi即“之字”,之字排列函数
    Dim arr3 As Variant
    Dim i_z As Integer, j_z As Integer
    
    ReDim arr3(1 To t_num, 1 To 4) As Variant
    For i_z = 1 To t_num
        If arr(i_z, 1) Mod 2 Then
            arr3(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)
        Else
            arr3(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 If
    Next
    zhizi = arr3
End Function

设置界面如下：