0

これは、簡単な答えがあるように感じる別の質問ですが、見つけられません。列 D の各セルをループして (ユーザー入力から) 特定の日付を探し、そのセルの日付と対応するセルの日付に基づいて、行の色を変更しています。

行に色を付ける代わりに、行を削除できるようにしたいと思います。

現在、これらの行に色を付ける私のコードは次のとおりです。

Range(Cells(2, 4), Cells(Rows.Count, 4).End(xlUp)).Select

Dim rCell, otherCell As Range
Dim TheAnswer$
Dim ConvertedDate#

TheAnswer = InputBox("In M/D/YY format, enter the first day of the month for which this report is being run." & _
                     vbCr & vbCr & "For example, you would enter ""12/1/2012"" for the December 2012 report.", "Enter Date M/D/YY")
ConvertedDate = CDate(TheAnswer)

For Each rCell In Selection
    If rCell.Value <> "" Then
        If rCell.Value And rCell.Offset(, 5) < ConvertedDate And rCell.Offset(, 5) <> "" Then rCell.EntireRow.Interior.Color = RGB(255, 102, 0)

        If rCell.Value < ConvertedDate And rCell.Offset(, 5) = "" Then

            If rCell.Offset(, 6) < ConvertedDate And rCell.Offset(, 6) <> "" Then rCell.EntireRow.Interior.Color = RGB(255, 102, 0)

            If rCell.Offset(, 7) < ConvertedDate And rCell.Offset(, 7) <> "" Then rCell.EntireRow.Interior.Color = RGB(255, 102, 0)

        End If

    End If
Next rCell

で置き換えるrCell.EntireRow.Interior.Color = RGB(255, 102, 0)とrCell.EntireRow.Delete、エラーが発生します。コードをステップ実行すると、実際には最初の行が削除されますが、次の行でエラーが発生することがわかります。

明らかに複数の「If Then」ステートメントがありますが、最初の「If Then」条件が満たされ、行が削除された場合、次のセルに移動する必要があります。削除された行をまだチェックしようとしているようです。私は間違いなく Excel VBA の専門家ではありませんがrCell.EntireRow.Delete、次のセルに移動するように指示する部分の後に何か追加する必要があると考えています。を追加しようとしましNext rCellたが、エラーになります。 Exit Forマクロを完全に停止するだけです。

4

2 に答える 2

2

マイク、範囲セットをループして行を削除するときは、最後の行から逆方向にループする必要があります。これは、行を削除すると存在しなくなり、その行がループ範囲に含まれなくなったため、Excel を通過するためです。

これを試して：

Range(Cells(2, 4), Cells(Rows.Count, 4).End(xlUp)).Select

Dim rCell as Range, otherCell As Range
Dim TheAnswer$
Dim ConvertedDate#

TheAnswer = InputBox("In M/D/YY format, enter the first day of the month for which this report is being run." & _
                     vbCr & vbCr & "For example, you would enter ""12/1/2012"" for the December 2012 report.", "Enter Date M/D/YY")
ConvertedDate = CDate(TheAnswer)

Dim xrows as Long, i as Long
xrows = Selection.Rows.Count

For i = xrows to 1 Step -1

    Set rCell = Selection.Cells(i,1)

    If rCell.Value <> "" Then
        If rCell.Value And rCell.Offset(, 5) < ConvertedDate And rCell.Offset(, 5) <> "" Then rCell.EntireRow.Delete

        If rCell.Value < ConvertedDate And rCell.Offset(, 5) = "" Then

            If rCell.Offset(, 6) < ConvertedDate And rCell.Offset(, 6) <> "" Then rCell.EntireRow.Delete

            If rCell.Offset(, 7) < ConvertedDate And rCell.Offset(, 7) <> "" Then rCell.EntireRow.Delete

        End If

    End If

Next i

すべてを にしたかったかどうかはわかりませんがEntireRow.Delete、簡単に元に戻すことができます。

于 2012-12-11T00:54:25.567 に答える
2

以下を参照してください。いくつかの重複条件を更新および変更しました。最良の 2 つの方法は、データをバリアント配列に追加し、処理してから削除するか、コメントで brettdj が言及しているように、フラグを追加し、フィルター処理してから一括削除することです。スケーリングがうまくいき、他のデータ操作について知っておくと良い方法であるため、私は以下を好みます。ベースとなるテンプレートがないため、テストされていません。下記参照：

Dim data() As Variant
Dim i As Double
Dim deleteRows As Range
Dim sht As Worksheet

Dim theAnswer As String
Dim ConvertedDate As Date

Set sht = Sheet1

theAnswer = InputBox("In M/D/YY format, enter the first day of the month for which this report is being run." & _
                 vbCr & vbCr & "For example, you would enter ""12/1/2012"" for the December 2012 report.", "Enter Date M/D/YY")
ConvertedDate = CDate(theAnswer)

data = sht.Range(Cells(2, 4), Cells(Rows.Count, 4).End(xlUp)).Resize(, 8)

    For i = 1 To UBound(data, 1)

        If (data(i, 1) <> vbNullString) Then

            If data(i, 1) <> vbNullString And data(i, 6) < ConvertedDate And data(i, 6) <> vbNullString Then

                If (deleteRows Is Nothing) Then
                    Set deleteRows = sht.Rows(i + 1)
                Else
                    Set deleteRows = Union(deleteRows, sht.Rows(i + 1))
                End If

            ElseIf data(i, 1) < ConvertedDate And data(i, 7) <> vbNullString And data(i, 8) <> vbNullString Then

                If data(i, 7) < ConvertedDate Or data(i, 8) < ConvertedDate Then

                    If (deleteRows Is Nothing) Then
                        Set deleteRows = sht.Rows(i + 1)
                    Else
                        Set deleteRows = Union(deleteRows, sht.Rows(i + 1))
                    End If

                End If

            End If

        End If

    Next i

deleteRows.Delete Shift:=xlUp
于 2012-12-11T10:33:51.390 に答える