刪除單元格內容並向上移動不加分類

@Doug克蘭西本網站提供一些十分讚賞的指導和溶液（如下所示），它清除細胞內容並在必要時移的行，以填補那些空白。

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 
    ActiveSheet.Range("A7:AG400").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

代碼正常工作，但我有一個小問題，並無過錯@Doug克蘭西的，在我的要求更多的變化。

爲了引導用戶在哪些行上添加新記錄，我設置了一個文本信號，即「輸入您的姓名」，它總是出現在第一個空行上，爲用戶添加新記錄做好準備。不幸的是，這種價值也被挑選出來，這就是我的問題所在。

我一直想了幾天，現在要拿出一個解決方案，其中的「排序」功能從上面的代碼中刪除，以保持不變，其餘功能。可惜沒有任何成功。

可能有人請，請看看這一點，並提供我如何能去除細胞分選一些指導。

許多的感謝和親切的問候

來源

2013-02-18 IRHM

怎麼樣，而不是使用文本「輸入您的名字「，使用單元格格式...像紅色突出顯示的單元格。一旦單元格包含一些文本，您可以關閉突出顯示。您也可以自動執行條件格式化以獲取要顯示的文本，而不必在單元格中顯示文本。 – 2013-02-18 17:10:27

嗨@ScottHoltzman，感謝您花時間回覆我的帖子。我曾想過這種做事的方式。儘管如此，我想看看我能否做到這一點。親切的問候。 Chris – IRHM 2013-02-18 17:43:45

在這種情況下，在「在此輸入您的姓名」的單元格之前結束您的排序範圍1單元格 – 2013-02-18 19:26:33

這方面的工作在過去的幾天後，我已經把以下解決方案：

Sub DelRow() 

Dim DoesItExist As Range 
Dim msg As VbMsgBoxResult 
Dim RangeToClear As Range 

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 Range("B7", Range("B" & Rows.Count).End(xlUp)) 
    .Value = Evaluate("if(" & .Address & "<>"""",if(isnumber(search(""Enter your name""," & _ 
     .Address & ")),""""," & .Address & "),"""")") 
End With 
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 

    ActiveSheet.Range("A7:AG400").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 
    Set DoesItExist = Sheets("Input").Range("B7:B10").Find("Enter your name") 
     If Not DoesItExist Is Nothing Then Exit Sub 
     Sheets("Input").Select 
     Range("B" & Rows.Count).End(xlUp).Offset(1, 0) = "Enter your name" 
     Columns("B:B").Locked = False ' to unlock the whole column 
     Columns("B:B").SpecialCells(xlCellTypeBlanks).Locked = True 
Application.EnableEvents = True 
End Sub

來源

2013-02-21 16:43:10 IRHM

刪除單元格內容並向上移動不加分類

回答

相關問題