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

删除行和保持输入范围

1 个答案: