删除行并维护输入范围

Question

我想知道是否有人可以帮助我。

几周以来，我一直在尝试寻找一种解决方案，让用户可以执行以下操作：

• 删除有数据和没有数据的行，
• 移动所有包含数据的行，使它们并排放置，
• 同时保持定义的“输入范围”

我整理了以下脚本，它清除单元格内容，因此不会改变“输入范围”。

Sub DelRow()

      Dim msg

          Sheets("Input").Protect "handsoff", userinterfaceonly:=True
          Application.EnableCancelKey = xlDisabled
          Application.EnableEvents = False
          msg = MsgBox("Are you sure you want to delete this row?", vbYesNo)
          If msg = vbNo Then Exit Sub
          With Selection
              Application.Intersect(.Parent.Range("A:S"), .EntireRow).Interior.ColorIndex = xlNone
              Application.Intersect(.Parent.Range("T:AE"), .EntireRow).Interior.ColorIndex = 42
              Selection.SpecialCells(xlCellTypeConstants).ClearContents
              Application.Intersect(.Parent.Range("C:AE"), .EntireRow).Locked = True
              Application.Intersect(.Parent.Range("AG:AG"), .EntireRow).Locked = True
          End With
              Application.EnableEvents = True
      End Sub

更新代码

Sub DelRow()
Dim RangeToClear As Range
Dim msg As VbMsgBoxResult

'Sheets("Input").Protect "handsoff", userinterfaceonly:=True
Application.EnableCancelKey = xlDisabled
Application.EnableEvents = False
msg = MsgBox("Are you sure you want to delete this row?", vbYesNo)
If msg = vbNo Then Exit Sub
With Selection
    Application.Intersect(.Parent.Range("A:S"), .EntireRow).Interior.ColorIndex = xlNone
    Application.Intersect(.Parent.Range("T:AE"), .EntireRow).Interior.ColorIndex = 42
    On Error Resume Next
    Set RangeToClear = Selection.SpecialCells(xlCellTypeConstants)
    On Error GoTo 0    ' or previously defined error handler
    If Not RangeToClear Is Nothing Then
        RangeToClear.ClearContents
    Else
    Selection.Sort Key1:=Range("B7"), Order1:=xlAscending, Header:=xlNo, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
    End If
    Application.Intersect(.Parent.Range("C:AE"), .EntireRow).Locked = True
    Application.Intersect(.Parent.Range("AG:AG"), .EntireRow).Locked = True
End With
Application.EnableEvents = True
End Sub

但问题在于，如果用户选择空白行，他们会收到“错误 400”消息，并且不会将行向上移动以位于彼此下方。

正如我所说，我花了很多时间试图找到解决方案，但没有任何成功。

如果有人能看到这个并就我如何实现这一目标提供一些指导，我将非常感激。

非常感谢和亲切的问候

Answer 1

如果选择为空，Selection.SpecialCells(xlCellTypeConstants).ClearContents 行 将失败，因为没有xlCellTypeConstants。您需要对此进行测试，并且仅在有内容时才清除内容：

编辑：尝试回答排序问题

我认为您无论如何都只想排序，所以我只是将Sort 移到ClearContents 之后。不过，我对 UsedRange 进行了排序，我认为这不是您想要的。您需要定义要排序的范围，可以使用 Excel 中的名称管理器或在您的代码中定义为命名范围。

Sub DelRow()
Dim RangeToClear As Range
Dim msg As VbMsgBoxResult

Sheets("Input").Protect "handsoff", userinterfaceonly:=True
Application.EnableCancelKey = xlDisabled
Application.EnableEvents = False
msg = MsgBox("Are you sure you want to delete this row?", vbYesNo)
If msg = vbNo Then Exit Sub
With Selection
    Application.Intersect(.Parent.Range("A:S"), .EntireRow).Interior.ColorIndex = xlNone
    Application.Intersect(.Parent.Range("T:AE"), .EntireRow).Interior.ColorIndex = 42
    On Error Resume Next
    Set RangeToClear = Selection.SpecialCells(xlCellTypeConstants)
    On Error GoTo 0    ' or previously defined error handler
    If Not RangeToClear Is Nothing Then
        RangeToClear.ClearContents
    End If
    'You need to define a range that you want sorted
    'here I've used UsedRange
    ActiveSheet.UsedRange.Sort Key1:=Range("B7"), Order1:=xlAscending, Header:=xlNo, _
                   OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
                   DataOption1:=xlSortNormal

    Application.Intersect(.Parent.Range("C:AE"), .EntireRow).Locked = True
    Application.Intersect(.Parent.Range("AG:AG"), .EntireRow).Locked = True
End With
Application.EnableEvents = True
End Sub