本文于2023年5月20日首发于本人同名公众号：Excel活学活用，更多文章案例请搜索关注！

☆本期内容概要☆

VBA动态添加控件用代码调整控件位置ReDim Preserve数组数组转置

前期分享过一个学生成绩筛选的例子（Excel VBA数组应用/网友求助/学生成绩筛选）：

当时感觉有一点奇怪，但也说不上来是什么问题。这两天偶尔想起来，感觉这个需求是不是应该是这样：

筛选成绩与参考标准成绩相差在一定范围内的同学？比如标准成绩是100，成绩差是20，那么根据不同情况，成绩在100~120，或80~100，或80~120这些范围内的同学都应该被选到。

个人认为这样理解还是具有很大的合理性的，那么，怎么来实现呢？

思考过程就不说了，直接动手吧：

1、插入一个Userform1，Name什么的就不改了

2、插入几个标签，一个命令按钮，LbSubject（科目）、LbStandard（标准）、LbDeviation（差值）、LbType（方式）、CmdConfirm（确定）：

3、在Userform1的代码块顶端定义几个变量：

Dim dynamicLabel As ControlDim arrA(), arrB(), arrC(), arrDetail()Dim iRow As IntegerDim iWidth As Integer

4、Userform1的Activate事件代码：

Private Sub UserForm_activate()    arrC = Array("正差", "负差", "正负差", "总差")    iWidth = 50    h = 5    With Me.LbSubject        .Left = 1        .Top = 1        .Width = iWidth    End With    With Me.LbStandard        .Left = Me.LbSubject.Left        .Top = Me.LbSubject.Top + Me.LbSubject.Height + h        .Width = Me.LbSubject.Width    End With    With Me.LbDeviation        .Left = Me.LbStandard.Left        .Top = Me.LbStandard.Top + Me.LbStandard.Height + h        .Width = Me.LbStandard.Width    End With    With Me.LbType        .Left = Me.LbDeviation.Left        .Top = Me.LbDeviation.Top + Me.LbDeviation.Height + h        .Width = Me.LbDeviation.Width    End With    Sheet1.Activate    With ActiveSheet        iRow = .UsedRange.Rows.Count        .Range("R4:AA" & iRow).ClearContents        iName = .Range("I2")        arrDetail = .Range("A7:J" & iRow).Value        arrA = .Range("K1:O2").Value        arrB = .Range("K4:O4").Value        For i = 1 To 5            Set dynamicLabel = Me.Controls.Add("Forms.Label.1", "dycLb_Subject" & i)            With dynamicLabel                .Caption = arrA(1, i)                .Top = Me.LbSubject.Top                .Height = Me.LbSubject.Height                .Width = iWidth                .Left = Me.LbSubject.Left + Me.LbStandard.Width + .Width * (i - 1)                .FontSize = 10                .FontName = "微软雅黑"                .ForeColor = RGB(50, 50, 255)                .TextAlign = 2            End With            Set dynamicLabel = Me.Controls.Add("Forms.Label.1", "dycLb_Standard" & i)            With dynamicLabel                .Caption = arrA(2, i)                .Top = Me.LbStandard.Top                .Height = Me.LbStandard.Height                .Width = iWidth                .Left = Me.LbStandard.Left + Me.LbStandard.Width + .Width * (i - 1)                .FontSize = 10                .FontName = "微软雅黑"                .ForeColor = RGB(128, 128, 128)                .TextAlign = 2            End With            Set dynamicLabel = Me.Controls.Add("Forms.TextBox.1", "dycTxb_" & i)            With dynamicLabel                .Text = arrB(1, i)                .Top = Me.LbDeviation.Top                .Height = Me.LbDeviation.Height                .Width = iWidth                .Left = Me.LbDeviation.Left + Me.LbDeviation.Width + .Width * (i - 1)                .FontSize = 10                .FontName = "微软雅黑"                .ForeColor = vbRed   ' RGB(50, 50, 255)                .TextAlign = 2                If i = 5 Then                    .BackColor = RGB(255, 204, 0)                End If            End With            If i < 5 Then                Set dynamicLabel = Me.Controls.Add("Forms.OptionButton.1", "dycOp_" & i)                With dynamicLabel                    .Caption = arrC(i - 1)                    .Top = Me.LbType.Top                    .Height = Me.LbType.Height                    .Width = iWidth                    .Left = Me.LbType.Left + Me.LbType.Width + .Width * (i - 1)                    .FontSize = 10                    .FontName = "微软雅黑"                    .ForeColor = vbRed   ' RGB(50, 50, 255)                    .Value = True                    .TextAlign = 2                End With             End If        Next    End With    Me.Height = Me.LbType.Top + Me.LbType.Height + 40    Me.Width = Controls("dycLb_Subject5").Left + Controls("dycLb_Subject5").Width + 20    Me.CmdConfirm.Top = Me.LbType.Top    Me.CmdConfirm.Left = Me.Width - Me.CmdConfirm.Width - 20End Sub

代码分析：

（1）以LbSubject为基准，调整其他标签的位置

（2）激活Sheet1，读入数据

（3）从1-5循环，动态添加控件，科目标签（语文~总分）、标准标签（各科分数）、差值文本框、方式选项按钮，并设置控件的各种属性。

（4）最后，调整UserForm1的大小，Height根据LbType.Top来调整，Width根据dycLb_Subject5来调整。

5、在Sheet1表添加命令按钮CmdQuery2（查询2），并输入代码：

Private Sub CmdQuery2_Click()    UserForm1.ShowEnd Sub

6、我们点击查询2：

这里，差值可以修改，总分差值是单独的数字，跟前面的各科差没有关系。方式，根据查询需要点选，默认是总差。

7、CmdConfirm（确定）按钮代码：

Private Sub CmdConfirm_Click()    Dim iType As String    Dim arrSelected()    '确定哪个选项被选中，取其Caption    For i = 1 To 4        If Controls("dycOp_" & i).Value = True Then            iType = Controls("dycOp_" & i).Caption        End If    Next    Sheet1.Activate    With ActiveSheet        If iType = "正差" Then            k = 0: m = 0            For i = 1 To UBound(arrDetail, 1)                For j = 1 To 4                    '正差，我们定义为：该同学成绩比标准成绩高，，幅度不超过差值                    If Round(arrDetail(i, j + 5) - arrA(2, j), 2) > Round(Controls("dycTxb_" & j), 2) _                        Or Round(arrDetail(i, j + 5) - arrA(2, j), 2) < 0 Then                    Exit For                    End If                    If j = 4 Then                        'Stop                        k = k + 1                        ReDim Preserve arrSelected(9, m)                        For p = 0 To 9                            arrSelected(p, m) = arrDetail(i, p + 1)                        Next                        m = m + 1                    End If                Next            Next            If k > 0 Then                .Cells(4, 18).Resize(UBound(arrSelected, 2) + 1, 10) = Application.WorksheetFunction.Transpose(arrSelected)            End If        ElseIf iType = "负差" Then            k = 0: m = 0            For i = 1 To UBound(arrDetail, 1)                For j = 1 To 4                    '负差，我们定义为：该同学成绩比标准成绩低，，幅度不超过差值                    If Round(arrA(2, j) - arrDetail(i, j + 5), 2) > Round(Controls("dycTxb_" & j), 2) _                        Or Round(arrA(2, j) - arrDetail(i, j + 5), 2) < 0 Then                    Exit For                    End If                    If j = 4 Then                        'Stop                        k = k + 1                        ReDim Preserve arrSelected(9, m)                        For p = 0 To 9                            arrSelected(p, m) = arrDetail(i, p + 1)                        Next                        m = m + 1                    End If                Next            Next            If k > 0 Then                .Cells(4, 18).Resize(UBound(arrSelected, 2) + 1, 10) = Application.WorksheetFunction.Transpose(arrSelected)            End If        ElseIf iType = "正负差" Then             k = 0: m = 0            For i = 1 To UBound(arrDetail, 1)                For j = 1 To 4                    '正负差，我们定义为：该同学成绩比标准成高或低，幅度不超过差值                    If Abs(Round(arrDetail(i, j + 5) - arrA(2, j), 2)) > Round(Controls("dycTxb_" & j), 2) Then                        Exit For                    End If                    If j = 4 Then                        'Stop                        k = k + 1                        ReDim Preserve arrSelected(9, m)                        For p = 0 To 9                            arrSelected(p, m) = arrDetail(i, p + 1)                        Next                        m = m + 1                    End If                Next            Next            If k > 0 Then                .Cells(4, 18).Resize(UBound(arrSelected, 2) + 1, 10) = Application.WorksheetFunction.Transpose(arrSelected)            End If        ElseIf iType = "总差" Then            k = 0: m = 0            For i = 1 To UBound(arrDetail, 1)                If Round(Abs(arrA(2, 5) - arrDetail(i, 10)), 2) <= Round(Controls("dycTxb_5")) Then                    'For p = 1 To 10                    '.Cells(4 + m, 17 + p) = arrDetail(i, p)                    'Next                    k = k + 1                    ReDim Preserve arrSelected(9, m)                    For p = 0 To 9                        arrSelected(p, m) = arrDetail(i, p + 1)                    Next                    m = m + 1                End If            Next            If k > 0 Then                .Cells(4, 18).Resize(UBound(arrSelected, 2) + 1, 10) = Application.WorksheetFunction.Transpose(arrSelected)            End If        Else            MsgBox "查询比较方式未选择！"            Exit Sub        End If        For i = 1 To 5            .Cells(4, 10 + i) = Controls("dycTxb_" & i)        Next    End With    MsgBox "查询完成！共【" & k & "】记录！"    Erase arrSelected    Unload MeEnd Sub

代码分析：

（1）首先通过循环，确定哪个选项被选中

（2）根据选项的Caption分别进行处理

（3）正差，我们定义为同学的成绩比标准高，但幅度不超过差值，即差值>同学-标准>0，在代码中，我们是排除不符合条件的记录；如果最终找到一条符合条件的记录，我们把它存到arrSelected（）数组里，这里我们采用Redim preserve方法，动态扩展数组，不断地写入符合条件的记录，同时把记录数记入k，作为判断arrSelected是否有记录的依据，在程序结尾的MsgBox也引用到k。

（4）把arrSelected的记录写入到EXCEL表格，注意要作一个转置。

（5）其他方式选项类似。

（6）查询完成后，把差值再回写到Excel表中的对应单元格。因为我们可能进行了修改。这里差值的调整方式有2种，一种是在点查询2命令按钮前，在EXCEL表中的K4~O4单元格进行修改，另一种是在显示的用户窗体中修改。

（7）代码并不复杂，难点在于各种查询方式的条件判断比较费脑筋，纯粹是数学问题。

好，今天就分享到这，欢迎点赞、留言、分享，谢谢大家，我们下期再会。

☆猜你喜欢☆

Excel VBA 这样酷炫的日期控件，你不想要吗？

Excel 公式函数/数据透视表/固定资产折旧计提表！

Excel VBA 自定义函数/数组字段定位/数组字段排序

Excel 功能/公式函数/VBA/多种姿势处理重复值

Excel VBA 最简单的收发存登记系统

Excel 公式函数/查找函数之LOOKUP

Excel VBA 文件批量改名

Excel 公式函数/数据验证/动态下拉列表

Excel VBA 输入逐步提示/TextBox+ListBox

Excel 基础功能【数据验证】，你会怎么用？

本文于2023年5月20日首发于本人同名公众号：Excel活学活用，更多文章案例请搜索关注！