Цикл по массиву и запись сообщений об ошибках

Question

У меня есть таблица A:G и в ней указаны c обязательные столбцы (A, C, D, F, G), где я выделяю ячейку и в G написание сообщения. Столбец F - это дата, и я также проверяю, что это <сегодня. Наконец, у меня возникла проблема с ошибкой 1004, поэтому я не могу войти в операторы For. </p>

Моя конечная цель - написать несколько сообщений об ошибках в столбце G, но я еще не там.

Любая помощь с благодарностью?

Option Base 1

Sub ValidateArrayColumns()

Dim errormsg() As Variant
Dim Drng As Long
Dim Row As Single
Dim Column As Single
Dim tmpDate As Variant
Dim IsError As Boolean
Dim arrReq(5) As Variant
Dim i As Single

arrReq(1) = Worksheets("Sheet2").Cells(Row, 1)
arrReq(2) = Worksheets("Sheet2").Cells(Row, 3)
arrReq(3) = Worksheets("Sheet2").Cells(Row, 4)
arrReq(4) = Worksheets("Sheet2").Cells(Row, 6)
arrReq(5) = Worksheets("Sheet2").Cells(Row, 7)

    Drng = Worksheets("Sheet2").Cells(Rows.Count, "A").End(xlUp).Row

    i = 1

    For Row = 2 To Drng
        For Column = 1 To 7
            If Column = arrReq(i) Then
                For i = 1 To arrReq(5)
                    If Cells(Row, arrReq(i)) = "" Then       'Required fields
                        Cells(Row, arrReq(i)).Interior.ColorIndex = 6
                        IsError = True
                    End If
                Next i
            End If
        Next Column

            'Checks Date
            tmpDate = Cells(Row, 4).Value
            If tmpDate = "" Then
                Cells(Row, 4).Interior.ColorIndex = 6
                IsError = True
            ElseIf tmpDate < Date Then
                Cells(Row, 4).Interior.ColorIndex = 4
                IsError = True
            End If

            'Writes error message
            If IsError = True Then
                Cells(Row, 8).Value = "Highlighted fields contain errors"
            End If

            IsError = False
    Next Row

End Sub

Answer 1

Прочитайте комментарии к коду и настройте его в соответствии с вашими потребностями

Option Explicit

Option Base 1

Private Sub ValidateRange()

    Dim evalSheet As Worksheet
    Dim evalRange As Range
    Dim evalRow As Range
    Dim evalCell As Range

    Dim evalSheetName As String
    Dim evalColumns As String

    Dim firstRow As Long
    Dim lastRowColumn As String
    Dim lastRow As Long
    Dim relativeCol As Long
    Dim counter As Long
    Dim columnCommments As Long

    Dim errorType As Long

    Dim errorCounter As Long
    Dim errorDescrip As String
    Dim errorConcat As String

    Dim validationRule(5) As Variant

    ' Adjust the parameters to fit your needs
    evalSheetName = "Sheet2"
    evalColumns = "A:G"
    lastRowColumn = "A"                          ' Column where it's going to be searched for the last non empty row
    firstRow = 2                                 ' Skip headers

    columnCommments = 8


    ' Define the rules like column number, validation type, error description

    validationRule(1) = Array(1, "Non empty")
    validationRule(2) = Array(3, "Non empty")
    validationRule(3) = Array(4, "Non empty")
    validationRule(4) = Array(6, "Non empty")
    validationRule(5) = Array(7, "Greater than today")

    ' Set a reference to the sheet where the validation takes place
    Set evalSheet = ThisWorkbook.Worksheets(evalSheetName)

    ' Find the last row with a value in a specific column
    lastRow = evalSheet.Cells(evalSheet.Rows.Count, lastRowColumn).End(xlUp).Row

    ' Define the range to be validated
    Set evalRange = Intersect(evalSheet.Range(evalColumns), evalSheet.Rows(firstRow & ":" & lastRow))

    ' Search per row
    For Each evalRow In evalRange.Rows

        ' Reset error counter
        errorCounter = 0

        ' Reset error comments
        evalSheet.Cells(evalRow.Row, columnCommments).Value = vbNullString

        ' Loop through all cells and check if they are required and empty
        For Each evalCell In evalRow.Cells

            ' Reset error description
            errorDescrip = vbNullString


            ' Cell column is relative to the column where the range begins
            relativeCol = (evalCell.Column - evalRange.Column + 1)

            ' Get the validation result per cell
            errorType = IsCellValidAndReturnErrorType(evalCell, relativeCol, validationRule)

            Select Case errorType
            Case 0
                ' Reset format
                evalCell.Interior.ColorIndex = 0
            Case 1
                errorDescrip = errorDescrip & " " & "Cell cannot be empty"
                evalCell.Interior.ColorIndex = 6
            Case 2
                errorDescrip = errorDescrip & " " & "Cell should be a date"
                evalCell.Interior.ColorIndex = 4
            Case 3
                errorDescrip = errorDescrip & " " & "Cell should be greater than today"
                    evalCell.Interior.ColorIndex = 3
            Case Else

            End Select


            If errorType <> 0 Then

                If errorCounter >= 1 Then
                    errorConcat = " | "
                Else
                    errorConcat = vbNullString
                End If

                evalSheet.Cells(evalRow.Row, columnCommments).Value = evalSheet.Cells(evalRow.Row, columnCommments).Value & errorConcat & evalCell.Address & " has error: " & errorDescrip
                errorCounter = errorCounter + 1
            End If

        Next evalCell

    Next evalRow

End Sub

Private Function IsCellValidAndReturnErrorType(ByVal evalCell As Range, ByVal cellColumn As Long, ByVal validationRule As Variant) As Long

    Dim errorType As Long
    Dim counter As Long
    Dim errorDescrip As String

    For counter = 1 To UBound(validationRule, 1)

        ' Check if cell column has validations
        If cellColumn = validationRule(counter)(1) Then

            ' Check if meets validation rule
            Select Case validationRule(counter)(2)
            Case "Non empty"
                If evalCell.Value = vbNullString Then
                    errorType = 1
                    Exit For
                End If
            Case "Greater than today"
                If IsDate(evalCell.Value) = False Then
                    errorType = 2
                    Exit For
                ElseIf evalCell.Value < Date Then
                    errorType = 3
                    Exit For
                End If
            Case Else
                errorType = 0
            End Select
        End If

    Next counter

    IsCellValidAndReturnErrorType = errorType

End Function

Некоторые предложения:

1. Всегда используйте Option в верхней части ваших модулей / классов (вы Вы избежите ошибок, используя необъявленные переменные)
2. Попробуйте присвоить своим переменным что-то значимое и читабельное

Answer 2

После объявления переменной строки строка по умолчанию = 0, поэтому

Worksheets ("Sheet2"). Cells (Row, 1) будет эквивалентно Worksheets ("Sheet2"). Cells (0, 1), что приводит к ошибке -> вам необходимо присвоить подходящее значение

Вот несколько небольших изменений в вашем коде:

 Option Base 1

Sub ValidateArrayColumns()

Dim errormsg() As Variant
Dim Drng As Long
Dim Row As Single
Dim Column As Single
Dim tmpDate As Variant
Dim IsError As Boolean
Dim arrReq(5) As Variant
Dim i As Single
Row = 1 '///
With Worksheets("Sheet2")
    arrReq(1) = .Cells(Row, 1)
    arrReq(2) = .Cells(Row, 3)
    arrReq(3) = .Cells(Row, 4)
    arrReq(4) = .Cells(Row, 6)
    arrReq(5) = .Cells(Row, 7)

    Drng = .Cells(Rows.Count, "A").End(xlUp).Row
End With
    i = 1

    For Row = 2 To Drng
        For Column = 1 To 7
            If Column = arrReq(i) Then
                For i = 1 To arrReq(5)
                    If Cells(Row, arrReq(i)) = vbNullString Then 'Required fields
                        Cells(Row, arrReq(i)).Interior.ColorIndex = 6
                        IsError = True
                        Exit For '///
                    End If
                Next i
            End If
        Next Column

            'Checks Date
            tmpDate = Cells(Row, 7).Value
            If tmpDate = vbNullString Then
                Cells(Row, 7).Interior.ColorIndex = 6
                IsError = True
            ElseIf tmpDate < Date Then
                Cells(Row, 7).Interior.ColorIndex = 4
                IsError = True
            End If

        'Writes error message
        If IsError = True Then
            Cells(Row, 8).Value = "Highlighted fields contain errors"
        End If

        IsError = False

    Next Row

End Sub