0

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

数週間、私はユーザーが次のことを実行できる解決策を見つけようとしてきました。

  • データのある行とない行を削除し、
  • データを含むすべての行をシフトして、それらが上下に配置されるようにします。
  • 定義された「入力範囲」を維持しながら

セルの内容をクリアして「入力範囲」を変更しない次のスクリプトをまとめました。

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」メッセージが表示され、行が上に移動して互いに下に配置されないことです。

私が言ったように、私はこれに多くの時間を費やして、成功せずに解決策を見つけようとしました。

誰かがこれを見て、私がこれをどのように達成することができるかについていくつかのガイダンスを提供することができれば、私は本当に感謝しています。

よろしくお願いします

4

1 に答える 1

0

選択が空白の場合、Selection.SpecialCells(xlCellTypeConstants).ClearContents がないため、行は失敗しxlCellTypeConstantsます。これをテストし、コンテンツがある場合にのみクリアする必要があります。

編集：並べ替えの質問に答えようとする

何があっても並べ替えたいと思うので、Sort後へ移動しましたClearContents。私はUsedRangeをソートしましたが、それはあなたが望むものではないと思います。並べ替える範囲を、ExcelのName Managerを使用した名前付き範囲として、またはコードで定義する必要があります。 

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
于 2013-02-09T15:32:30.597 に答える