如何用VBA实现产品数量可变的企业调研数据按行转存至数据库？

我有一份调研表，不同企业的产品数量从1到10个不等。需要把每家企业的调研数据转存到数据库，要求每个产品单独占一行，对应企业名称重复显示。目标格式如下：

我原本写的VBA代码只适用于固定产品数量的场景，没办法适配不同企业产品数量可变的情况，修改后也没得到满意结果，原代码如下：

Public Sub Transfer_Data_frm()
Dim ws As Worksheet
Dim rng1 As Range
Dim dados As Variant
Dim i As Long

ActiveWorkbook.Worksheets("DB_Production").Select
Set ws = Sheets(2)


Set rng1 = ws.Cells(Rows.Count, "A").End(xlUp)
ultimaLinha = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row

        dados = Array(Array( _
          Worksheets("Questionário").Cells(7, "C").Value, _
          Worksheets("Questionário").Range("E7").Value, _
          Worksheets("Questionário").Range("C12").Value, _
          Worksheets("Questionário").Range("N12").Value, _
          Worksheets("Questionário").Range("C30").Value, _
          Worksheets("Questionário").Range("K30").Value, _
          Worksheets("Questionário").Range("C67").Value, _ 
          Worksheets("Questionário").Range("G67").Value, _
          Worksheets("Questionário").Range("H67").Value, _
          Worksheets("Questionário").Range("I67").Value, _
          Worksheets("Questionário").Range("J67").Value, _
          Worksheets("Questionário").Range("K67").Value, _
          Worksheets("Questionário").Range("M67").Value, _
          Worksheets("Questionário").Range("C73").Value, _
          Worksheets("Questionário").Range("C76").Value, _
          Now()))

        
            ' Loop para lançar os dados na planilha
    For i = LBound(dados) To UBound(dados)
        ' Verificar se a célula está vazia e parar o loop se estiver
        'If IsEmpty(ws.Cells(ultimaLinha + 1, 1)) Then Exit For
        ws.Cells(ultimaLinha + 1, 1).Value = dados(i)(0) '
        ws.Cells(ultimaLinha + 1, 2).Value = dados(i)(1) '
        ws.Cells(ultimaLinha + 1, 3).Value = dados(i)(2) '
        ws.Cells(ultimaLinha + 1, 4).Value = dados(i)(3) '
        ws.Cells(ultimaLinha + 1, 5).Value = dados(i)(4) '
        ws.Cells(ultimaLinha + 1, 6).Value = dados(i)(5) '
        ws.Cells(ultimaLinha + 1, 7).Value = dados(i)(6) '
        ws.Cells(ultimaLinha + 1, 8).Value = dados(i)(7) '
        ws.Cells(ultimaLinha + 1, 9).Value = dados(i)(8) '
        ws.Cells(ultimaLinha + 1, 10).Value = dados(i)(9) '
        ws.Cells(ultimaLinha + 1, 11).Value = dados(i)(10) '
        ws.Cells(ultimaLinha + 1, 12).Value = dados(i)(11) '
        ws.Cells(ultimaLinha + 1, 13).Value = dados(i)(12) '
        ws.Cells(ultimaLinha + 1, 14).Value = dados(i)(13) '
        ws.Cells(ultimaLinha + 1, 15).Value = dados(i)(14) '
        ws.Cells(ultimaLinha + 1, 16).Value = dados(i)(15) '
        ultimaLinha = ultimaLinha + 1
    Next i

End Sub

以下代码可根据企业实际产品数量动态生成行，核心是先识别所有非空产品条目，再循环将企业信息与对应产品数据逐行写入目标表：

Public Sub Transfer_Data_Dynamic()
    Dim wsTarget As Worksheet
    Dim wsForm As Worksheet
    Dim lastRowTarget As Long
    Dim productRowStart As Integer
    Dim maxProducts As Integer
    Dim enterpriseName As String
    Dim i As Integer
    
    ' 绑定工作表对象，避免使用Select提升效率
    Set wsTarget = ThisWorkbook.Worksheets("DB_Production")
    Set wsForm = ThisWorkbook.Worksheets("Questionário")
    
    ' 配置参数：产品起始行、最大产品数、企业名称位置
    productRowStart = 12 ' 产品信息从第12行开始
    maxProducts = 10     ' 最多支持10个产品
    enterpriseName = wsForm.Cells(7, "C").Value ' 企业名称在C7
    
    ' 获取目标表最后一行
    lastRowTarget = wsTarget.Cells(wsTarget.Rows.Count, "A").End(xlUp).Row
    
    ' 循环遍历产品条目，遇到空行则停止
    For i = 0 To maxProducts - 1
        ' 当前产品所在行
        currentProductRow = productRowStart + i
        ' 检查产品名称是否为空，为空则终止循环
        If wsForm.Cells(currentProductRow, "C").Value = "" Then Exit For
        
        ' 写入企业名称
        wsTarget.Cells(lastRowTarget + 1, "A").Value = enterpriseName
        ' 写入产品名称（对应表单C列）
        wsTarget.Cells(lastRowTarget + 1, "B").Value = wsForm.Cells(currentProductRow, "C").Value
        ' 写入产品数量（对应表单N列）
        wsTarget.Cells(lastRowTarget + 1, "C").Value = wsForm.Cells(currentProductRow, "N").Value
        
        ' 写入其他固定字段（根据原代码对应位置调整）
        wsTarget.Cells(lastRowTarget + 1, "D").Value = wsForm.Range("E7").Value
        wsTarget.Cells(lastRowTarget + 1, "E").Value = wsForm.Range("K30").Value
        wsTarget.Cells(lastRowTarget + 1, "F").Value = wsForm.Range("C30").Value
        wsTarget.Cells(lastRowTarget + 1, "P").Value = Now() ' 时间戳
        
        ' 更新目标表最后一行计数
        lastRowTarget = lastRowTarget + 1
    Next i
    
    ' 释放对象
    Set wsTarget = Nothing
    Set wsForm = Nothing
    
    MsgBox "数据转存完成！"
End Sub

• 动态适配产品数量：通过循环检查产品行是否为空，自动停止，完美支持1到10个产品的可变场景。
• 复用企业信息：每次循环重复写入企业名称，满足每个产品单独一行的格式要求。
• 优化操作逻辑：直接通过对象引用操作工作表，避免Select带来的不稳定问题，提升代码效率。
• 可扩展性：若需调整产品起始行、最大数量或字段对应关系，只需修改代码中的参数配置即可。

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