Excel VBA调整表格大小：复制公式与形状时触发下标越界错误

首先，咱们来定位你代码里的问题根源：

错误原因分析 #

你在新增行时的这段代码有明显的问题：

Selection.AutoFill Destination:=ob.ListRows(count & ":" & TextBox1.value).Range, Type:=xlFillDefault

ListRows是表格的数据行集合，它只能接受单个整数索引（比如ob.ListRows(5)表示第5行数据），而你用count & ":" & TextBox1.value这种字符串范围来引用，VBA根本无法识别，直接导致「下标越界」错误。

另外，代码里用Select来操作单元格也不是最佳实践——不仅容易引发错误，还会降低代码运行效率，咱们可以直接操作Range对象来避免这个问题。

修正后的完整代码 #

我把你的代码调整了一下，修复了错误，同时优化了逻辑和健壮性：

Private Sub UserForm_Initialize()
    Dim ob As ListObject
    Dim count As Integer
    Set ob = Sheets("Worksheet").ListObjects("Table1")
    ' 数据行数 = 表格总行数 - 表头行
    count = ob.Range.Rows.Count - 1
    TextBox1.Value = count
End Sub

Private Sub OKButton_Click()
    ' 先关闭Excel的交互功能，提升运行速度
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    
    Dim ob As ListObject
    Dim currentRowCount As Integer, targetRowCount As Integer
    Set ob = Sheets("Worksheet").ListObjects("Table1")
    currentRowCount = ob.Range.Rows.Count - 1
    
    ' 验证输入合法性：必须是大于等于2的整数
    If Not IsNumeric(TextBox1.Value) Then
        MsgBox "请输入有效的数字！", vbExclamation
        TextBox1.SetFocus
        GoTo Cleanup
    End If
    targetRowCount = CInt(TextBox1.Value)
    If targetRowCount < 2 Then
        MsgBox "行数不能小于2！", vbExclamation
        TextBox1.SetFocus
        GoTo Cleanup
    End If
    
    If targetRowCount > currentRowCount Then
        ' 计算需要新增的行数
        Dim addRows As Integer
        addRows = targetRowCount - currentRowCount
        
        ' 获取当前最后一行数据的范围（包含公式和形状）
        Dim lastDataRow As Range
        Set lastDataRow = ob.ListRows(currentRowCount).Range
        
        ' 调整表格大小，容纳新增行
        ob.Resize ob.Range.Resize(targetRowCount + 1)
        
        ' 定义AutoFill的目标范围：从原最后一行到新的最后一行
        Dim fillTarget As Range
        Set fillTarget = ob.Range.Rows(currentRowCount + 1).Resize(addRows + 1)
        
        ' 执行自动填充，复制公式和格式（包括绑定的形状）
        lastDataRow.AutoFill Destination:=fillTarget, Type:=xlFillDefault
        
    ElseIf targetRowCount < currentRowCount Then
        ' 删除多余的行
        ob.Range.Rows(targetRowCount + 1 & ":" & currentRowCount + 1).Delete
    End If

Cleanup:
    ' 恢复Excel的交互功能
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    Unload Me
End Sub

关键优化点说明 #

1. 修复ListRows引用错误：直接通过Range的行范围来定义AutoFill目标，不再使用错误的ListRows范围引用
2. 增加输入验证：避免用户输入非数字或小于2的数值，提前拦截错误
3. 移除Select操作：直接操作Range对象，让代码更稳定高效
4. 结构化错误处理：用GoTo Cleanup确保无论是否出错，都能恢复Excel的正常状态

关于形状复制的补充 #

如果你的形状是嵌入在表格单元格内（比如形状的位置与单元格绑定，随单元格复制），AutoFill会自动复制这些形状；如果是自由浮动的形状，可能需要额外代码来复制并定位到新行——但从你的描述来看，每行都有对应形状，应该是绑定单元格的情况，上述代码完全可以满足需求。

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