Excel VBA: условие пропуска в счетчике, если критерии выполнены

У меня есть кусок кода, и я хотел бы улучшить его, добавив критерии к моим счетчикам.

Текущий код работает так:

• У меня есть целевая книга, куда я вставляю другие книги, в которые я хочу сделать несколько счетчиков
• Я определяю название своих рабочих книг, ключевые слова, путь к ним, имя рабочего листа, столбец
• Когда я запускаю код, он подсчитывает с учетом вышеупомянутых критериев заданные ключевые слова и записывает их в TargetBook.xlsm.

Что я хочу улучшить:

1. для подсчета мне нужно условие проверки, если эта строка содержит определенное слово, чтобы не считать его. Это слово в моем примере «устарело». Я поместил это в строку 13. Это столбец всегда должен быть одинаковым, столбец C (не уверен, если это имеет значение)

2. У меня также есть некоторые проблемы с опечатками, и я хотел бы видеть опечатки в отдельном поле. Я подумал о другом столбце в TargetBook, где они могут отображаться каким-либо образом.

3. Существует также проблема подсчета одного и того же ключевого слова несколько раз. Если у меня есть, например, Sample1 и Sample12, ключевое слово для Sample1 будет засчитано дважды.

Я надеюсь, что прилагаемый рисунок является хорошим примером вывода, и я ценю помощь.

пример картинки

 Sub Main () Dim Path As String Dim Wb As Workbook Dim File As Range, All As Range, KeyWord As Range, KeyWords As Range Dim FName As String, WName As String, CName As String, PName As String Тусклый результат () As Long Дим я, как долго Dim SaveCalculation  Path = Range ("J1") Если верно (путь, 1) "\" Тогда путь = путь & "\" WName = Range ("J2") CName = Range ("J3") CName = CName & ":" & CName Set KeyWords = Range ("B1: G1")  SaveCalculation = Application.Calculation Application.ScreenUpdating = False Application.EnableEvents = False Application.Calculation = xlCalculationManual  Для каждого файла в диапазоне («A2», Range («A» & Rows.Count) .End (xlUp)) FName = Path & File.Value Восстановить результат (от 1 до KeyWords.Count) If Dir (FName) "" Тогда Set Wb = Workbooks.Open (FName, False, True) Если не WorksheetExists (WName, Wb), то GoTo SkipWb я = 0 Для каждого ключевого слова в ключевых словах я = я + 1 Если не IsEmpty (KeyWord), то Установить все = FindAll (Wb.Worksheets (WName) .Range (CName), KeyWord.Value, LookAt: = xlPart) Если не все - ничто, тогда Результат (i) = All.Count Конец, если Конец, если следующий SkipWb: Wb.Close False Конец, если File.Offset (, 1) .Resize (, UBound (Result)). Value = Result следующий  Application.EnableEvents = True Application.Calculation = SaveCalculation End Sub  Рабочий лист закрытой функции Exists (ByVal SheetNameOrIndex как вариант, _ Необязательный ByVal Wb As Workbook = Nothing) As Boolean 'True, если существует лист SheetNameOrIndex При ошибке возобновить следующее Если Wb - ничто, тогда установите Wb = ActiveWorkbook WorksheetExists = Not Wb.Worksheets (SheetNameOrIndex) - это ничто Конечная функция  Частная функция FindAll (ByVal Где As Range, ByVal What, _ Необязательный вариант ByVal After As, _ Необязательный ByVal LookIn As XlFindLookIn = xlValues, _ Необязательный ByVal LookAt As XlLookAt = xlWhole, _ Необязательный ByVal SearchOrder As XlSearchOrder = xlByRows, _ Необязательный ByVal SearchDirection As XlSearchDirection = xlNext, _ Необязательный ByVal MatchCase As Boolean = False, _ Необязательный ByVal SearchFormat As Boolean = False) As Range «Найти все вхождения What in Where (версия для Windows) Dim FirstAddress As String Dim C As Range 'Из FastUnion: Dim Stack As New Collection Dim Temp () As Range, предмет Дим я так долго, Дж как долго  Если где нет ничего, тогда выход из функции Если SearchDirection = xlNext и IsMissing (после), то 'Установить после к последней ячейке в Где вернуть первую ячейку в Где впереди, если _ Это соответствует Что Установите C = Где. Области (Where.Areas.Count) 'Ошибка в XL2010: Cells.Count производит RTE 6, если C - весь лист 'Set After = C.Cells (C.Cells.Count) Установить после = C.Cells (C.Rows.Count * CDec (C.Columns.Count)) Конец, если  Установите C = Where.Find (Что, После, LookIn, LookAt, SearchOrder, _ SearchDirection, MatchCase, SearchFormat: = SearchFormat) Если C - ничто, выход из функции  FirstAddress = C.Address Делать Stack.Add C Если SearchFormat Тогда «Если вы вызываете эту функцию из UDF и _ вы найдете только первую ячейку использовать это вместо Установите C = Where.Find (Что, C, LookIn, LookAt, SearchOrder, _ SearchDirection, MatchCase, SearchFormat: = SearchFormat) еще Если SearchDirection = xlNext Тогда Установить C = Где.FindNext (C) еще Установить C = Где.FindPrevious (C) Конец, если Конец, если «Может случиться, если мы объединили клетки Если C - ничто, тогда выход Цикл до первого адреса = C. адрес  «Получить все клетки как фрагменты ReDim Temp (от 0 до Stack.Count - 1) я = 0 Для каждого предмета в стеке Set Temp (i) = Item я = я + 1 следующий Объедините каждый фрагмент со следующим J = 1 Делать Для i = 0 до UBound (Temp) - j Шаг j * 2 Установить Temp (i) = Союз (Temp (i), Temp (i + j)) следующий j = j * 2 Цикл До j> UBound (Temp) «На данный момент у нас есть все клетки в первом фрагменте Установите FindAll = Temp (0) Конечная функция