1

誰かが私を助けてくれるのではないかと思います。

このサイトの@DougClancyは、非常に高く評価されているガイダンスとソリューション（以下に表示）を提供しました。これにより、セルの内容がクリアされ、必要に応じて行が上に移動して空白の行が埋められます。

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 Clancyの障害がなく、要件がさらに変更されているため、わずかな問題があります。

ユーザーが新しいレコードを追加する必要がある行をガイドするために、テキスト信号、つまり「名前を入力してください」を設定しました。これは常に最初の空の行に表示され、ユーザーが新しいレコードを追加できるようになっています。残念ながら、この値はソートでも取得されます。これが私の問題です。

私は数日間、「並べ替え」機能を上記のコードから削除し、残りの機能をそのままにしておくという解決策を考え出そうとしています。残念ながら成功しませんでした。

誰かお願いします。これを見て、セルの並べ替えを削除する方法についてのガイダンスを提供してください。

よろしくお願いします

4

1 に答える 1

1

ここ数日間これに取り組んだ後、次の解決策をまとめました。

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-21T16:43:10.187 に答える