Форум по VBA и MS Office

Sub Gen()

    Dim numRows As Integer
    Dim cellMappings As Variant
    Dim i As Integer, j As Integer
    Dim newOrderArrays() As String

    ' изначальный массив
    cellMappings = Array( _
        Array(2, 2, 2), Array(3, 2, 4), _
        Array(2, 5, 2), Array(3, 5, 4), _
        Array(2, 3, 1), Array(3, 3, 3) _
    )

   
    numRows = InputBox("Введите количество строк заказа:", "Количество строк заказа") ' запрос количества строк от пользователя
   
   
        If Not IsNumeric(numRows) Then                                ' проверяем, является ли вводимое значение числом
            MsgBox "Введено не число.", vbCritical
            Exit Sub
        End If
       
       
        numRows = CInt(numRows) '    строка в целое число
       
        'генерация новых строк заказа
        ReDim newOrderArrays(0 To numRows * 3 - 1)
        Dim index As Integer
        index = 0
        For i = 1 To numRows
            newOrderArrays(index) = "Array(" & (i + 1) & ", 2, " & (2 * i) & ")"
            index = index + 1
            newOrderArrays(index) = "Array(" & (i + 1) & ", 5, " & (2 * i) & ")"
            index = index + 1
            newOrderArrays(index) = "Array(" & (i + 1) & ", 3, " & (2 * i - 1) & ")"
            index = index + 1
           
            If i < numRows Then
                newOrderArrays(index) = "_"  'добавляем разделитель
                index = index + 1
            End If
        Next i
       
       
        If numRows < UBound(cellMappings) + 1 Then 'обновление cellMappings
           
            Dim newCellMappings() As Variant 'ббновляем существующий массив, если количество меньше
            ReDim newCellMappings(0 To (numRows * 3) - 1)
           
            For i = 0 To (numRows * 3) - 1 'копируем элементы в новый массив
                newCellMappings(i) = newOrderArrays(i)
            Next i
           
            cellMappings = newCellMappings 'устанавливаем новое значение для cellMappings
        Else
           
            cellMappings = newOrderArrays 'если больше или равно, просто запишем новые значения
        End If
       
       
        Dim result As String ' вывод результата
        result = "Новый массив строк заказов:" & vbCrLf
        For i = LBound(cellMappings) To UBound(cellMappings)
            result = result & cellMappings(i) & vbCrLf
        Next i
       
       
        MsgBox result, vbInformation, "Результат" 'оказать результат

End Sub