Argthtjtr

I have a piece of code and I would like to improve it by adding a criteria to my counters.

The current code works like this:

• I have a target book where I insert the other workbooks where I want to do some counters


• I define the name of my WorkBooks, Key Words, Path where they are, Worksheet name, Column


• When I run the code, it counts with the above defined criteria the given Key Words and writes them up in the TargetBook.xlsm

What I want to improve:

1. for the counting part I need a check condition if that line contains a specific word to not count it. That word in my example is "Obsolete". I've put it on line 13. It's column should always be the same, column C (not sure if it matters)




2. I also have some trouble with typing errors and I would like to see the typos in a separate field. I've thought of another column in the TargetBook where those can be displayed in some manner.




3. There is also the problem of counting the same key word multiple times. If I have for example Sample1 and Sample12, the key word for Sample1 will be counted twice.

I hope the attached pic is a good example of the output and I appreciate the help.

example pic

    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

  Dim Result() As Long

  Dim i As Long

  Dim SaveCalculation



  Path = Range("J1")

  If Right(Path, 1)  "" Then Path = Path & ""

  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



  For Each File In Range("A2", Range("A" & Rows.Count).End(xlUp))

    FName = Path & File.Value

    ReDim Result(1 To KeyWords.Count)

    If Dir(FName)  "" Then

      Set Wb = Workbooks.Open(FName, False, True)

      If Not WorksheetExists(WName, Wb) Then GoTo SkipWb

      i = 0

      For Each KeyWord In KeyWords

        i = i + 1

        If Not IsEmpty(KeyWord) Then

          Set All = FindAll(Wb.Worksheets(WName).Range(CName), KeyWord.Value, LookAt:=xlPart)

          If Not All Is Nothing Then

            Result(i) = All.Count

          End If

        End If

      Next

SkipWb:

      Wb.Close False

    End If

    File.Offset(, 1).Resize(, UBound(Result)).Value = Result

  Next



  Application.EnableEvents = True

  Application.Calculation = SaveCalculation

End Sub



Private Function WorksheetExists(ByVal SheetNameOrIndex As Variant, _

    Optional ByVal Wb As Workbook = Nothing) As Boolean

  'True if worksheet SheetNameOrIndex exists

  On Error Resume Next

  If Wb Is Nothing Then Set Wb = ActiveWorkbook

  WorksheetExists = Not Wb.Worksheets(SheetNameOrIndex) Is Nothing

End Function



Private Function FindAll(ByVal Where As Range, ByVal What, _

    Optional ByVal After As Variant, _

    Optional ByVal LookIn As XlFindLookIn = xlValues, _

    Optional ByVal LookAt As XlLookAt = xlWhole, _

    Optional ByVal SearchOrder As XlSearchOrder = xlByRows, _

    Optional ByVal SearchDirection As XlSearchDirection = xlNext, _

    Optional ByVal MatchCase As Boolean = False, _

    Optional ByVal SearchFormat As Boolean = False) As Range

  'Find all occurrences of What in Where (Windows version)

  Dim FirstAddress As String

  Dim C As Range

  'From FastUnion:

  Dim Stack As New Collection

  Dim Temp() As Range, Item

  Dim i As Long, j As Long



  If Where Is Nothing Then Exit Function

  If SearchDirection = xlNext And IsMissing(After) Then

    'Set After to the last cell in Where to return the first cell in Where in front if _

      it match What

    Set C = Where.Areas(Where.Areas.Count)

    'BUG in XL2010: Cells.Count produces a RTE 6 if C is the whole sheet

    'Set After = C.Cells(C.Cells.Count)

    Set After = C.Cells(C.Rows.Count * CDec(C.Columns.Count))

  End If



  Set C = Where.Find(What, After, LookIn, LookAt, SearchOrder, _

    SearchDirection, MatchCase, SearchFormat:=SearchFormat)

  If C Is Nothing Then Exit Function



  FirstAddress = C.Address

  Do

    Stack.Add C

    If SearchFormat Then

      'If you call this function from an UDF and _

        you find only the first cell use this instead

      Set C = Where.Find(What, C, LookIn, LookAt, SearchOrder, _

        SearchDirection, MatchCase, SearchFormat:=SearchFormat)

    Else

      If SearchDirection = xlNext Then

        Set C = Where.FindNext(C)

      Else

        Set C = Where.FindPrevious(C)

      End If

    End If

    'Can happen if we have merged cells

    If C Is Nothing Then Exit Do

  Loop Until FirstAddress = C.Address



  'Get all cells as fragments

  ReDim Temp(0 To Stack.Count - 1)

  i = 0

  For Each Item In Stack

    Set Temp(i) = Item

    i = i + 1

  Next

  'Combine each fragment with the next one

  j = 1

  Do

    For i = 0 To UBound(Temp) - j Step j * 2

      Set Temp(i) = Union(Temp(i), Temp(i + j))

    Next

    j = j * 2

  Loop Until j > UBound(Temp)

  'At this point we have all cells in the first fragment

  Set FindAll = Temp(0)

End Function