VBA宏开发求助：多输入值实现新增行自动填充异常问题

我需要开发一个VBA宏，要求根据用户输入确定新增行数，且每行需填入用户提供的不同数值，实现多输入值对应每行自动填充。目前编写了如下代码：

Sub AddRows1()

Dim ws1         As Worksheet
Dim LastR      As Long, LastR2 As Long
Dim cell        As Range, lastRowRange As Range, lastRowRange2 As Range, LastRow As Integer, Foundrow As Range, i As Integer
Dim frameRows   As String, StartRow As String, BlockName As String, BlockVariable As String
Dim artn As String
Dim frsize_1 As Integer
Dim frsize_2 As Integer
Dim frsize_3 As Integer

Set ws1 = ActiveSheet

LastR = ws1.Cells(Rows.Count, "A").End(xlUp).Row

StartRow = LastR

Start:
        artn = InputBox("Please enter the mainnumber?")
        frameRows = InputBox("How many frame sizes are available?")
        frsize_1 = InputBox("First frame size (cm)?")
        frsize_2 = InputBox("Second frame size (cm)?")
        frsize_3 = InputBox("Third frame size (cm)?")
        If frameRows = "" Then Exit Sub
        If Not IsNumeric(frameRows) Then
            MsgBox "Please enter a numeric value!", vbCritical, "Not a numeric value"
            GoTo Start
        End If

Application.ScreenUpdating = False

ws1.Range("A" & LastR + 1 & "").EntireRow.Hidden = False

ws1.Rows(LastR + 1).Resize(frameRows).Insert
ws1.Rows(LastR + 1).Resize(frameRows + 1).FillUp
With ws1.Range("D" & LastR + 1)
  .Resize(frameRows).NumberFormat = "@"
  .Value = frsize_1
  If frameRows > 1 Then .AutoFill .Resize(frameRows), xlFillValues
End With
ws1.Rows(LastR).Offset(frameRows + 1).EntireRow.Hidden = True
              
Application.ScreenUpdating = True

End Sub

当输入3（新增行数）、40、50、80时，所有新增行都填充了40，期望每行分别填充40、50、80，请问代码存在什么问题，该如何修改？

问题分析与修改方案 #

问题根源 #

1. 代码固定将frsize_1赋值给所有新增行的D列，完全未使用frsize_2和frsize_3；
2. AutoFill xlFillValues仅会重复填充初始单元格的值，无法实现多值逐行分配；
3. 预设3个尺寸变量的写法不灵活，无法适配用户输入行数大于3的场景。

修改后的代码 #

Sub AddRows1()
    Dim ws1 As Worksheet
    Dim LastR As Long
    Dim frameRows As Integer
    Dim artn As String
    Dim sizeArr() As Variant
    Dim i As Integer
    
    Set ws1 = ActiveSheet
    LastR = ws1.Cells(Rows.Count, "A").End(xlUp).Row
    
Start:
    artn = InputBox("请输入主编号？")
    frameRows = InputBox("有多少种尺寸？")
    
    ' 输入合法性校验
    If frameRows = "" Then Exit Sub
    If Not IsNumeric(frameRows) Then
        MsgBox "请输入数字！", vbCritical, "输入无效"
        GoTo Start
    End If
    If frameRows < 1 Then
        MsgBox "行数不能小于1！", vbCritical, "输入无效"
        GoTo Start
    End If
    
    ' 动态存储所有尺寸输入
    ReDim sizeArr(1 To frameRows)
    For i = 1 To frameRows
        sizeArr(i) = InputBox("请输入第" & i & "个尺寸(cm)？")
        ' 可选：校验尺寸是否为数字
        If Not IsNumeric(sizeArr(i)) Then
            MsgBox "第" & i & "个尺寸必须是数字！", vbCritical, "输入无效"
            GoTo Start
        End If
    Next i
    
    Application.ScreenUpdating = False
    
    ws1.Range("A" & LastR + 1).EntireRow.Hidden = False
    ' 插入指定数量的行
    ws1.Rows(LastR + 1).Resize(frameRows).Insert
    ' 复制上一行的格式与内容
    ws1.Rows(LastR).Copy ws1.Rows(LastR + 1).Resize(frameRows)
    
    ' 将尺寸值逐行填充到D列
    ws1.Range("D" & LastR + 1 & ":D" & LastR + frameRows).NumberFormat = "@"
    ws1.Range("D" & LastR + 1 & ":D" & LastR + frameRows).Value = Application.Transpose(sizeArr)
    
    ws1.Rows(LastR + frameRows + 1).EntireRow.Hidden = True
    
    Application.ScreenUpdating = True
End Sub

核心修改点说明 #

1. 动态数组存储尺寸：用sizeArr动态存储用户输入的所有尺寸，不再局限于固定3个变量，适配任意行数输入；
2. 循环获取多值输入：通过循环逐个收集每个尺寸的输入，确保每个新增行对应独立的尺寸值；
3. 数组转置批量赋值：用Application.Transpose将一维数组转置后直接赋值给D列连续单元格，实现一次性逐行填充；
4. 强化输入校验：新增行数最小值判断，可选校验每个尺寸是否为数字，提升代码健壮性；
5. 简化复制逻辑：替换FillUp为Copy，更直观地复制上一行内容。

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