Excel VBA 调整表格大小复制公式和形状答案

【问题标题】：Excel VBA Resize Table Copying Formulas & ShapesExcel VBA 调整表格大小复制公式和形状
【发布时间】：2020-12-08 21:23:02
【问题描述】：

我有一个表格，每一行都包含公式和形状。

我想根据用户表单中的用户输入来调整表的大小（让我们只调用给定 TextBox1.Value 的值）用户在用户表单中输入新的所需表行大小并单击“确定”

让我们调用表Table1，见下面的代码：

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()
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    Dim ob As ListObject
    Dim count As Integer, i As Integer, j As Integer
    Set ob = Sheets("Worksheet").ListObjects("Table1")
    count = ob.Range.Rows.count - 1
    If TextBox1.value < 2 Then
        Unload Me
    ElseIf TextBox1.value > count Then
        ob.Resize ob.Range.Resize(TextBox1.value + 1)
        ob.ListRows(count).Range.Select
        Selection.AutoFill Destination:=ob.ListRows(count & ":" &_ 
        TextBox1.value).Range,Type:=xlFillDefault
        ob.ListRows(TextBox1).Range.Select
    ElseIf TextBox1.value < count Then
        ob.Range.Rows(TextBox1.value + 1 & ":" & count).Delete
    End If
    Application.CutCopyMode = False
    Unload Me
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
End Sub

我的问题是当用户输入的值大于表的当前行数时。

表格大小调整正确，但复制行时出错。

“运行时错误 9，下标超出范围”

希望将公式和形状快速复制到新创建的行中。

谁能看出我做错了什么？

【问题讨论】：

"...复制行时出错"。这是什么错误？另请注意，您应该avoid using .Select/.Activate
运行时错误9，下标超出范围错误，如果有办法避免使用Select，我会全力以赴。这是我现在看到的唯一方式
删除 ob.ListRows(count).Range.Select 行，并将 AutoFill 行替换为：ob.ListRows(count).AutoFill Destination:=ob.ListRows(...)?
删除了两个ob.ListRows(count).Range.Select 行，将自动填充行更改为ob.ListRows(count).AutoFill Destination:=ob.ListRows(count & ":" & TextBox1.value) 是否出现同样的错误？即使将行号明确定义为“10:12”，仍然会出现该错误。仍在使用它以尝试减轻该错误。

标签： excel vba

【解决方案1】：

您不能像使用工作表行一样引用多个 ListRows，例如 ListRows(1:2)。该属性不支持该参数语法。将 ElseIf 更改为

ElseIf TextBox1.Value > count Then
    ob.Resize ob.Range.Resize(TextBox1.Value + 1)
    ob.ListRows(count).Range.Resize(Me.TextBox1.Value - count + 1).FillDown

你会避免这个错误。

【讨论】：

【解决方案2】：

以下是任何可能使用它的人都能正常使用的结果：

Private Sub UserForm_Initialize()
    Dim ob As ListObject
    Dim count As Integer, i As Integer, j As Integer
    Set ob = Sheets("Worksheet").ListObjects("Table1")
    count = ob.Range.Rows.count - 1
    TextBox1.value = count
End Sub

Private Sub OKButton_Click()
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    Dim ob As ListObject
    Dim count As Integer, i As Integer, j As Integer, k As Integer, m As Integer
    Set ob = Sheets("Worksheet").ListObjects("Table1")
    count = ob.Range.Rows.count - 1
    If TextBox1.value < 2 Then
        Unload Me
    ElseIf TextBox1.value > count Then
        ob.Resize ob.Range.Resize(TextBox1.value + 1)
        ob.ListRows(count).Range.Resize(Me.TextBox1.value - count + 1).FillDown
    ElseIf TextBox1.value < count Then
        Debug.Print "TextBox1:" & TextBox1.value & " count:" & count
        ob.Range.Rows(TextBox1.value + 2 & ":" & count + 1).Delete
    End If
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    ActiveSheet.UsedRange
    Unload Me
End Sub

【讨论】：