Excel VBA: Bedingung zum Überspringen eines Zählers, wenn Kriterien erfüllt sind

Ich habe einen Code, den ich verbessern möchte, indem ich meinen Zählern ein Kriterium hinzufüge.

Der aktuelle Code funktioniert folgendermaßen:

• Ich habe ein Zielbuch, in das ich die anderen Arbeitsmappen einfügt, in denen ich einige Zähler ausführen möchte
• Ich definiere den Namen meiner WorkBooks, Schlüsselwörter, Pfad, in dem sie sich befinden, Arbeitsblattname, Spalte
• Wenn ich den Code ausführt, zählt er mit den oben definierten Kriterien die angegebenen Schlüsselwörter und schreibt sie in die TargetBook.xlsm

Was ich verbessern möchte:

1. Für den Zählteil brauche ich eine Prüfbedingung, wenn diese Zeile ein bestimmtes Wort enthält, um es nicht zu zählen. Dieses Wort in meinem Beispiel ist "veraltet". Ich habe es auf Zeile 13 gesetzt. Die Spalte sollte immer die gleiche sein, Spalte C (nicht sicher, ob es wichtig ist)

2. Ich habe auch Probleme mit Tippfehlern, und ich möchte die Tippfehler in einem separaten Feld sehen. Ich habe an eine andere Spalte im TargetBook gedacht, wo diese auf irgendeine Weise angezeigt werden kann.

3. Es besteht auch das Problem, dasselbe Schlüsselwort mehrfach zu zählen. Wenn ich beispielsweise Sample1 und Sample12 habe, wird das Schlüsselwort für Sample1 zweimal gezählt.

Ich hoffe das beigefügte Bild ist ein gutes Beispiel für die Ausgabe und ich freue mich über die Hilfe.

Beispiel Bild

 Sub Main () Dim Pfad als Zeichenfolge Dim Wb als Arbeitsmappe Dim-Datei als Bereich, Alle als Bereich, KeyWord als Bereich, KeyWords als Bereich Dim FName As String, WName As String, CName As String, PName As String Dimmen Sie Ergebnis () so lang Dimm ich so lange Dim SaveCalculation  Pfad = Bereich ("J1") Wenn richtig (Pfad, 1) "\" Dann Pfad = Pfad & "\" WName = Bereich ("J2") CName = Range ("J3") CName = CName & ":" & CName Set KeyWords = Range ("B1: G1")  SaveCalculation = Anwendungsberechnung Application.ScreenUpdating = False Application.EnableEvents = False Application.Calculation = xlCalculationManual  Für jede Datei in Bereich ("A2", Bereich ("A" und Zeilen.Zahl) .End (xlUp)) FName = Pfad & Datei.Wert ReDim-Ergebnis (1 bis KeyWords.Count) Wenn Dir (FName) "" Dann Setze Wb = Workbooks.Open (FName, False, True) Wenn kein Arbeitsblatt vorhanden ist (WName, Wb), dann GoTo SkipWb i = 0 Für jedes KeyWord in KeyWords i = i + 1 If Not IsEmpty (KeyWord) Dann Set All = FindAll (Wb.Worksheets (WName) .Range (CName), KeyWord.Value, LookAt: = xlPart) Wenn nicht alles nichts ist Ergebnis (i) = All.Count Ende wenn Ende wenn Nächster SkipWb: Wb.Close False Ende wenn File.Offset (, 1) .Resize (, UBound (Ergebnis)). Wert = Ergebnis Nächster  Application.EnableEvents = True Application.Calculation = SaveCalculation End Sub  Private Function WorksheetExists (ByVal SheetNameOrIndex als Variante, _ Optional ByVal Wb As Workbook = Nothing As Boolean 'True, wenn Arbeitsblatt SheetNameOrIndex vorhanden ist On Error Resume Next Wenn Wb nichts ist, dann setzen Sie Wb = ActiveWorkbook WorksheetExists = Not Wb.Worksheets (SheetNameOrIndex) ist nichts Funktion beenden  Private Funktion FindAll (ByVal Where as Range, ByVal What, _ Optionales ByVal nach als Variante, _ Optionales ByVal-LookIn als XlFindLookIn = xlValues, _ Optionaler ByVal LookAt As XlLookAt = xlWhole, _ Optionale ByVal SearchOrder als XlSearchOrder = xlByRows, _ Optionale ByVal SearchDirection As XlSearchDirection = xlNext, _ Optionales ByVal MatchCase As Boolean = False, _ Optional ByVal SearchFormat As Boolean = False) As Range 'Alle Vorkommen von Was in Wo finden (Windows-Version) Dim FirstAddress As String Dim C As Range 'Von FastUnion: Dim Stack als neue Kollektion Dim Temp () As Range, Element Dim i so lang, j so lang  Wenn wo nichts ist, dann beenden Sie die Funktion Wenn SearchDirection = xlNext und IsMissing (after) Then 'Setze nach auf die letzte Zelle in Wo soll die erste Zelle in Where in Front zurückgegeben werden, wenn _ es passt zu was Set C = Where.Areas (Where.Areas.Count) 'BUG in XL2010: Cells.Count erzeugt eine RTE 6, wenn C das gesamte Blatt ist 'Set After = C.Cells (C.Cells.Count) Set After = C.Cells (C.Rows.Count * CDec (C.Columns.Count)) Ende wenn  Setze C = Where.Find (Was, Nach, LookIn, LookAt, SearchOrder, _ SearchDirection, MatchCase, SearchFormat: = SearchFormat) Wenn C nichts ist, dann beenden Sie die Funktion  FirstAddress = C.Address Tun Stack.Add C Wenn SearchFormat Then 'Wenn Sie diese Funktion von einer UDF aufrufen und _ Sie finden nur die erste Zelle, die stattdessen diese verwendet Set C = Where.Find (Was, C, LookIn, LookAt, SearchOrder, _) SearchDirection, MatchCase, SearchFormat: = SearchFormat) Sonst Wenn SearchDirection = xlNext Then Setze C = Where.FindNext (C) Sonst Setze C = Where.FindPrevious (C) Ende wenn Ende wenn 'Kann passieren, wenn wir Zellen zusammengefügt haben Wenn C nichts ist, dann beenden Sie den Vorgang Schleife bis zur ersten Adresse = C.Adresse  'Holen Sie sich alle Zellen als Fragmente ReDim Temp (0 bis Stack.Count - 1) i = 0 Für jeden Artikel im Stapel Setze Temp (i) = Gegenstand i = i + 1 Nächster Kombinieren Sie jedes Fragment mit dem nächsten j = 1 Tun Für i = 0 bis UBound (Temp) - j Schritt j * 2 Setze Temp (i) = Vereinigung (Temp (i), Temp (i + j)) Nächster j = j * 2 Schleife bis j> UBound (Temp) 'Zu diesem Zeitpunkt haben wir alle Zellen im ersten Fragment SetAllAll = Temp (0) Funktion beenden