刪除行並維護輸入範圍 (Delete Rows & Maintain Input Range)

問題描述

刪除行並維護輸入範圍 (Delete Rows & Maintain Input Range)

I wonder whether someone may be able to help me please.

For a few weeks now I've been trying to find a solution whereby users can do the following:

• Delete rows with and without data,
• Shift all rows containing data aso that they sit one under another,
• Whilst maintaining a defined 'Input Range'

I've put together the following script which clears the cell contents and hence doesn't alter the 'Input Range'.

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

Updated Code

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

The problem with this though, is that if a user selects a blank row they receive a 'Error 400' message and it doesn't shift the rows up to sit underneath each other.

As I said, I've spent so much time on this trying to find a solution without any success.

I really would be so grateful if someone could look at this please and offer some guidance on how I may achieve this.

Many thanks and kind regards

‑‑‑‑‑

參考解法

方法 1:

If the selection is blank, the line Selection.SpecialCells(xlCellTypeConstants).ClearContents will fail because there are no xlCellTypeConstants. You need to test this and only clear the content if there are any:

EDIT: To try to answer Sorting question

I think you just want to sort no matter what, so I just moved the Sort to after the ClearContents. I sorted the UsedRange though, which I don't think is what you want. You need to define the range to be sorted, either as a named range using the Name Manager in Excel, or in your code.   

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

(by IRHM、Doug Glancy)

參考文件

1. Delete Rows & Maintain Input Range (CC BY‑SA 3.0/4.0)