Hello Every One VBA Experts!
I have a survey like this. One Company may have 1 to 10 products and this number veries from company to company.
I would Like to transfer each company survey to a Base, when each product will take a row, and the company name will repeat for all products it sells.

In the Data Base I need something like this!

The code I used is this but its serves for a fixed number of products and I need for a variable number of products for different companies. I will appreciate every help. I tried but I cant arrive to a satisfyed results.

`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`