Всем привет! Рад поделиться скриптом, который ищет пропущенные порядковые номера, а также нарушения в порядке, например, если после 5 идет 3. [vba]
Код
Sub searchX() Dim wbkU As Workbook Dim Check As Range, cellX As Range Dim X, W Dim i As Integer, iMax As Integer Dim lCell As Long, lRowsInCheck As Long, lLastRow As Long Dim absent As String, errorChain As String
Set wbkU = ThisWorkbook Set Check = wbkU.Sheets("Лист1").Range("таблица1[№ п/п]") 'проверяемый диапазон
absent = "Отсутствуют номера: " errorChain = "Нарушен порядок в строках: "
For Each cellX In Check ' X = cellX.Value lCell = lCell + 1 If lCell = lRowsInCheck Then Exit For 'выход на последней ячейке If X <> "" Then For i = 1 To iMax 'пропуск пустых ячеек If i = iMax Then Exit For W = cellX.Offset(i, 0).Value If cellX.Offset(i, 0).Row = lLastRow And W = "" Then GoTo endX If W <> "" Then Exit For Next i
If W <= X Then errorChain = errorChain & cellX.Row + 1 & "; ": cellX.Interior.Color = 255: GoTo nextX 'нарушен порядок If W - X = 2 Then absent = absent & X + 1 & "; ": cellX.Interior.Color = 49407 'пропущен один № If W - X > 2 Then absent = absent & "c " & X + 1 & " по " & W - 1 & "; ": cellX.Interior.Color = 49407 'пропущено несколько номеров End If nextX: Next cellX endX: wbkU.Sheets("Лист1").Range("F1") = absent wbkU.Sheets("Лист1").Range("F2") = errorChain MsgBox absent & Chr(13) & errorChain End Sub
[/vba] Пример приложил. P.S. отредактировал код, т.к. первичный некорректно работал, если в последней ячейке проверяемого диапазона было пусто. Пример тоже заменил
Всем привет! Рад поделиться скриптом, который ищет пропущенные порядковые номера, а также нарушения в порядке, например, если после 5 идет 3. [vba]
Код
Sub searchX() Dim wbkU As Workbook Dim Check As Range, cellX As Range Dim X, W Dim i As Integer, iMax As Integer Dim lCell As Long, lRowsInCheck As Long, lLastRow As Long Dim absent As String, errorChain As String
Set wbkU = ThisWorkbook Set Check = wbkU.Sheets("Лист1").Range("таблица1[№ п/п]") 'проверяемый диапазон
absent = "Отсутствуют номера: " errorChain = "Нарушен порядок в строках: "
For Each cellX In Check ' X = cellX.Value lCell = lCell + 1 If lCell = lRowsInCheck Then Exit For 'выход на последней ячейке If X <> "" Then For i = 1 To iMax 'пропуск пустых ячеек If i = iMax Then Exit For W = cellX.Offset(i, 0).Value If cellX.Offset(i, 0).Row = lLastRow And W = "" Then GoTo endX If W <> "" Then Exit For Next i
If W <= X Then errorChain = errorChain & cellX.Row + 1 & "; ": cellX.Interior.Color = 255: GoTo nextX 'нарушен порядок If W - X = 2 Then absent = absent & X + 1 & "; ": cellX.Interior.Color = 49407 'пропущен один № If W - X > 2 Then absent = absent & "c " & X + 1 & " по " & W - 1 & "; ": cellX.Interior.Color = 49407 'пропущено несколько номеров End If nextX: Next cellX endX: wbkU.Sheets("Лист1").Range("F1") = absent wbkU.Sheets("Лист1").Range("F2") = errorChain MsgBox absent & Chr(13) & errorChain End Sub
[/vba] Пример приложил. P.S. отредактировал код, т.к. первичный некорректно работал, если в последней ячейке проверяемого диапазона было пусто. Пример тоже заменилLeprotto