如何高效将Excel用户表单数据批量填充至表格？

我目前需要在Excel中维护产品数据库，经理虽已计划更换为专业数据库，但现阶段仍需继续使用Excel。为避免手动逐个单元格填写产品信息，我想找更快捷的方式。现有一个带多标签的用户表单，需填写约350项不同数据（不同产品需填写的项数不同），原本打算用以下VBA代码逐个将表单数据赋值到Sheet1的新行：

Private Sub OK_Click()

    'variable to store the count of rows.
    Dim irow As Long
    Dim iRowCode As Long

    'get the count cells that are filled
    irow = WorksheetFunction.CountA(Worksheets("Bron calculatie").Range("D:D"))

    'get to the next blank cell in column G
    Worksheets("Sheet1").Cells(irow + 1, 7).Value = ADD_ITEM.ART.Value
    Worksheets("Sheet1").Cells(irow + 1, 8).Value = ADD_ITEM.BREED.Value
    Worksheets("Sheet1").Cells(irow + 1, 9).Value = ADD_ITEM.DIEP.Value
    Worksheets("Sheet1").Cells(irow + 1, 10).Value = ADD_ITEM.ZITH.Value
    Worksheets("Sheet1").Cells(irow + 1, 11).Value = ADD_ITEM..Value
    Worksheets("Sheet1").Cells(irow + 1, 12).Value = ADD_ITEM..Value
    Worksheets("Sheet1").Cells(irow + 1, 13).Value = ADD_ITEM..Value
    Worksheets("Sheet1").Cells(irow + 1, ).Value = ADD_ITEM..Value
    Worksheets("Sheet1").Cells(irow + 1, ).Value = ADD_ITEM..Value
    Worksheets("Sheet1").Cells(irow + 1, ).Value = ADD_ITEM..Value
    Worksheets("Sheet1").Cells(irow + 1, ).Value = ADD_ITEM..Value
    Worksheets("Sheet1").Cells(irow + 1, ).Value = ADD_ITEM..Value
    Worksheets("Sheet1").Cells(irow + 1, ).Value = ADD_ITEM..Value
    Worksheets("Sheet1").Cells(irow + 1, ).Value = ADD_ITEM..Value
    Worksheets("Sheet1").Cells(irow + 1, ).Value = ADD_ITEM..Value
    Worksheets("Sheet1").Cells(irow + 1, ).Value = ADD_ITEM..Value
    Worksheets("Sheet1").Cells(irow + 1, ).Value = ADD_ITEM..Value
    Worksheets("Sheet1").Cells(irow + 1, ).Value = ADD_ITEM..Value
    Worksheets("Sheet1").Cells(irow + 1, ).Value = ADD_ITEM..Value
    Worksheets("Sheet1").Cells(irow + 1, ).Value = ADD_ITEM..Value
    Worksheets("Sheet1").Cells(irow + 1, ).Value = ADD_ITEM..Value
    Worksheets("Sheet1").Cells(irow + 1, ).Value = ADD_ITEM..Value
    Worksheets("Sheet1").Cells(irow + 1, ).Value = ADD_ITEM..Value
    Worksheets("Sheet1").Cells(irow + 1, ).Value = ADD_ITEM..Value
    Worksheets("Sheet1").Cells(irow + 1, ).Value = ADD_ITEM..Value
    Worksheets("Sheet1").Cells(irow + 1, ).Value = ADD_ITEM..Value
    Worksheets("Sheet1").Cells(irow + 1, ).Value = ADD_ITEM..Value
    Worksheets("Sheet1").Cells(irow + 1, ).Value = ADD_ITEM..Value
    Worksheets("Sheet1").Cells(irow + 1, ).Value = ADD_ITEM..Value
    Worksheets("Sheet1").Cells(irow + 1, ).Value = ADD_ITEM..Value
    Worksheets("Sheet1").Cells(irow + 1, ).Value = ADD_ITEM..Value
    Worksheets("Sheet1").Cells(irow + 1, ).Value = ADD_ITEM..Value
    Worksheets("Sheet1").Cells(irow + 1, ).Value = ADD_ITEM..Value
    Worksheets("Sheet1").Cells(irow + 1, ).Value = ADD_ITEM..Value
    Worksheets("Sheet1").Cells(irow + 1, ).Value = ADD_ITEM..Value
    Worksheets("Sheet1").Cells(irow + 1, ).Value = ADD_ITEM..Value
    Worksheets("Sheet1").Cells(irow + 1, ).Value = ADD_ITEM..Value
    Worksheets("Sheet1").Cells(irow + 1, ).Value = ADD_ITEM..Value


    MsgBox Chr(10) & "Artikel is toegevoegd" & Chr(10)
    
    Unload Me
    End

End Sub

但由于需赋值的项数多达350个，这种逐个赋值的方式效率极低，请问是否有更快捷简便的方法实现该需求？

方案一：控件-列映射数组批量赋值 #

通过定义存储控件名称和对应目标列号的数组，循环遍历数组完成批量赋值，无需重复编写350行赋值代码：

Private Sub OK_Click()
    Dim ws As Worksheet
    Dim irow As Long
    Dim ctrlMap As Variant
    Dim i As Integer
    Dim targetCtrl As Control
    
    ' 指定目标工作表
    Set ws = ThisWorkbook.Worksheets("Sheet1")
    ' 获取下一个空行（沿用原逻辑，基于"Bron calculatie"的D列计数）
    irow = WorksheetFunction.CountA(ThisWorkbook.Worksheets("Bron calculatie").Range("D:D")) + 1
    
    ' 定义控件名与目标列的映射数组，按格式添加所有350项
    ctrlMap = Array( _
        Array("ART", 7), _
        Array("BREED", 8), _
        Array("DIEP", 9), _
        Array("ZITH", 10), _
        ' 继续添加剩余控件：Array("控件名称", 列号),
        Array("ExampleCtrl", 11) _
    )
    
    ' 循环遍历映射数组完成赋值
    For i = LBound(ctrlMap) To UBound(ctrlMap)
        On Error Resume Next ' 忽略不存在的控件报错
        Set targetCtrl = Me.Controls(ctrlMap(i)(0))
        On Error GoTo 0
        
        If Not targetCtrl Is Nothing Then
            ws.Cells(irow, ctrlMap(i)(1)).Value = targetCtrl.Value
        End If
    Next i
    
    MsgBox Chr(10) & "Artikel is toegevoegd" & Chr(10)
    Unload Me
End Sub

方案二：按多标签页遍历控件（自动匹配表头） #

如果表单使用MultiPage控件做分标签，且控件名称与Sheet1的表头名称完全一致，可以直接遍历所有标签页的控件，自动匹配目标列，无需手动维护映射数组：

Private Sub OK_Click()
    Dim ws As Worksheet
    Dim irow As Long
    Dim mp As MultiPage
    Dim page As Page
    Dim ctrl As Control
    Dim targetCol As Range
    
    Set ws = ThisWorkbook.Worksheets("Sheet1")
    irow = WorksheetFunction.CountA(ThisWorkbook.Worksheets("Bron calculatie").Range("D:D")) + 1
    ' 假设你的多标签控件名为MultiPage1，根据实际修改
    Set mp = Me.MultiPage1
    
    ' 遍历每个标签页下的所有控件
    For Each page In mp.Pages
        For Each ctrl In page.Controls
            ' 在Sheet1的第一行查找与控件名匹配的表头
            Set targetCol = ws.Rows(1).Find(ctrl.Name, LookIn:=xlValues, LookAt:=xlWhole)
            If Not targetCol Is Nothing Then
                ws.Cells(irow, targetCol.Column).Value = ctrl.Value
            End If
        Next ctrl
    Next page
    
    MsgBox Chr(10) & "Artikel is toegevoegd" & Chr(10)
    Unload Me
End Sub

方案对比 #

• 方案一：适合控件与列的对应关系固定的场景，代码严谨，不易出错，需要手动维护映射数组。
• 方案二：灵活性更高，新增控件时只要命名和表头一致就自动生效，无需修改代码，但要求控件名与表头严格匹配。

内容的提问来源于stack exchange，提问作者DannyDutchie