执行VBA代码后Excel按钮位置与尺寸异常问题求助

我编写了如下VBA代码用于清理表格行：

Sub code_clearance_cable()
Dim ws As Worksheet, dict
Dim lastrow As Long, i As Long, n As Long
Dim key As String
Dim xCell As Range
Dim xRng1 As Range

Dim fso, ts
Set fso = CreateObject("Scripting.FilesystemObject")
Set ts = fso.CreateTextFile("debug.txt")

Set dict = CreateObject("Scripting.Dictionary")
Set ws = ThisWorkbook.Sheets("Cable Work Order")
Set xRng1 = ws.Columns("H")
With ws
    lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
    For i = lastrow To 2 Step -1
         If Len(Trim(.Cells(i, "H"))) = 0 Then
            key = Trim(.Cells(i, "A"))
            If dict.exists(key) Then
               .Rows(i).Delete
               n = n + 1
            Else
               dict.Add key, i
            End If
        Else
            key = ""
        End If
        ts.writeline i & " A='" & .Cells(i, "A") & "' H='" _
            & .Cells(i, "H") & "' key='" & key & "' n=" & n
     Next
  End With
  ts.Close

 End Sub

尽管已将按钮设置为不随单元格移动和大小调整，但执行该代码后，关闭并重新打开文档时，表单控件和ActiveX按钮的位置与尺寸均出现异常。请问能否通过编程方式解决该问题？

可以通过编程方式锁定控件的位置和尺寸，在删除行的代码执行前后添加控件属性设置逻辑，具体方法如下：

方法1：操作前锁定控件，操作后确认（推荐） #

在删除行操作前，先将工作表上所有表单控件和ActiveX控件的位置行为强制设置为固定，执行完删除操作后再确认属性：

Sub code_clearance_cable()
Dim ws As Worksheet, dict
Dim lastrow As Long, i As Long, n As Long
Dim key As String
Dim xCtrl As Object ' 遍历控件用

Dim fso, ts
Set fso = CreateObject("Scripting.FilesystemObject")
Set ts = fso.CreateTextFile("debug.txt")

Set dict = CreateObject("Scripting.Dictionary")
Set ws = ThisWorkbook.Sheets("Cable Work Order")
Set xRng1 = ws.Columns("H")

' --- 新增：锁定所有控件位置 ---
' 处理表单控件
For Each xCtrl In ws.Shapes
    If xCtrl.Type = msoFormControl Then
        xCtrl.Placement = xlFreeFloating ' 固定不随单元格变动
        xCtrl.Locked = True
    End If
Next
' 处理ActiveX控件
For Each xCtrl In ws.OLEObjects
    xCtrl.Placement = xlFreeFloating
    xCtrl.Locked = True
Next
' --- 锁定结束 ---

With ws
    lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
    For i = lastrow To 2 Step -1
         If Len(Trim(.Cells(i, "H"))) = 0 Then
            key = Trim(.Cells(i, "A"))
            If dict.exists(key) Then
               .Rows(i).Delete
               n = n + 1
            Else
               dict.Add key, i
            End If
        Else
            key = ""
        End If
        ts.writeline i & " A='" & .Cells(i, "A") & "' H='" _
            & .Cells(i, "H") & "' key='" & key & "' n=" & n
     Next
  End With

' --- 再次确认控件属性，防止意外变动 ---
For Each xCtrl In ws.Shapes
    If xCtrl.Type = msoFormControl Then
        xCtrl.Placement = xlFreeFloating
    End If
Next
For Each xCtrl In ws.OLEObjects
    xCtrl.Placement = xlFreeFloating
Next

ts.Close

 End Sub

方法2：删除行后重置控件位置 #

如果方法1无效，可以在删除行前记录控件的原始位置和尺寸，操作完成后用记录值重置：

Sub code_clearance_cable()
Dim ws As Worksheet, dict
Dim lastrow As Long, i As Long, n As Long
Dim key As String
Dim xCtrl As Object
Dim ctrlProps As Object ' 存储控件原始属性

Dim fso, ts
Set fso = CreateObject("Scripting.FilesystemObject")
Set ts = fso.CreateTextFile("debug.txt")

Set dict = CreateObject("Scripting.Dictionary")
Set ws = ThisWorkbook.Sheets("Cable Work Order")
Set xRng1 = ws.Columns("H")
Set ctrlProps = CreateObject("Scripting.Dictionary")

' --- 记录控件原始位置和尺寸 ---
For Each xCtrl In ws.Shapes
    If xCtrl.Type = msoFormControl Then
        ctrlProps.Add xCtrl.Name, Array(xCtrl.Top, xCtrl.Left, xCtrl.Width, xCtrl.Height)
    End If
Next
For Each xCtrl In ws.OLEObjects
    ctrlProps.Add xCtrl.Name, Array(xCtrl.Top, xCtrl.Left, xCtrl.Width, xCtrl.Height)
Next
' --- 记录结束 ---

With ws
    lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
    For i = lastrow To 2 Step -1
         If Len(Trim(.Cells(i, "H"))) = 0 Then
            key = Trim(.Cells(i, "A"))
            If dict.exists(key) Then
               .Rows(i).Delete
               n = n + 1
            Else
               dict.Add key, i
            End If
        Else
            key = ""
        End If
        ts.writeline i & " A='" & .Cells(i, "A") & "' H='" _
            & .Cells(i, "H") & "' key='" & key & "' n=" & n
     Next
  End With

' --- 重置控件位置和尺寸 ---
For Each xCtrl In ws.Shapes
    If ctrlProps.exists(xCtrl.Name) Then
        xCtrl.Top = ctrlProps(xCtrl.Name)(0)
        xCtrl.Left = ctrlProps(xCtrl.Name)(1)
        xCtrl.Width = ctrlProps(xCtrl.Name)(2)
        xCtrl.Height = ctrlProps(xCtrl.Name)(3)
        xCtrl.Placement = xlFreeFloating
    End If
Next
For Each xCtrl In ws.OLEObjects
    If ctrlProps.exists(xCtrl.Name) Then
        xCtrl.Top = ctrlProps(xCtrl.Name)(0)
        xCtrl.Left = ctrlProps(xCtrl.Name)(1)
        xCtrl.Width = ctrlProps(xCtrl.Name)(2)
        xCtrl.Height = ctrlProps(xCtrl.Name)(3)
        xCtrl.Placement = xlFreeFloating
    End If
Next
' --- 重置结束 ---

ts.Close

 End Sub

额外注意事项 #

• 如果工作表处于保护状态，需先解除保护（ws.Unprotect Password:="你的密码"），操作完成后再重新保护（ws.Protect Password:="你的密码"）
• 可在代码开头添加Application.EnableEvents = False，结尾添加Application.EnableEvents = True，避免删除行时触发控件的意外事件

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