Домашняя страница Undo Do New Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

Напомнить пароль

 

= Мир MS Excel/Поиск отсутствующих порядковых номеров - Мир MS Excel

Старая форма входа
  • Страница 1 из 1
  • 1
Модератор форума: _Boroda_, китин  
Мир MS Excel » Вопросы и решения » Готовые решения » Поиск отсутствующих порядковых номеров (Excel)
Поиск отсутствующих порядковых номеров
Leprotto Дата: Четверг, 31.08.2017, 13:45 | Сообщение № 1
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 145
Репутация: 2 ±
Замечаний: 0% ±

Excel 2016
Всем привет!
Рад поделиться скриптом, который ищет пропущенные порядковые номера, а также нарушения в порядке, например, если после 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[№ п/п]") 'проверяемый диапазон
  
  lRowsInCheck = Check.Rows.Count 'количество строк
  lLastRow = lRowsInCheck + Check.Range("A1").Row - 1 '№ строки последней ячейки
  iMax = 10 'максимальное количество пустых ячеек между номерами
  Check.Interior.Pattern = xlNone 'снятие заливки ячеек
  
  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. отредактировал код, т.к. первичный некорректно работал, если в последней ячейке проверяемого диапазона было пусто.
Пример тоже заменил
К сообщению приложен файл: findAbsentNum.xlsm (31.8 Kb)


Сообщение отредактировал Leprotto - Пятница, 01.09.2017, 12:07
 
Ответить
СообщениеВсем привет!
Рад поделиться скриптом, который ищет пропущенные порядковые номера, а также нарушения в порядке, например, если после 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[№ п/п]") 'проверяемый диапазон
  
  lRowsInCheck = Check.Rows.Count 'количество строк
  lLastRow = lRowsInCheck + Check.Range("A1").Row - 1 '№ строки последней ячейки
  iMax = 10 'максимальное количество пустых ячеек между номерами
  Check.Interior.Pattern = xlNone 'снятие заливки ячеек
  
  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
Дата добавления - 31.08.2017 в 13:45
Мир MS Excel » Вопросы и решения » Готовые решения » Поиск отсутствующих порядковых номеров (Excel)
  • Страница 1 из 1
  • 1
Поиск:

Яндекс.Метрика Яндекс цитирования
© 2010-2024 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!