Link to home
Start Free TrialLog in
Avatar of Skylar
Skylar

asked on

follow question on solution given by Fabrice Lambert and Sam Jacobs

This is a follow question on solution given by  Fabrice Lambert and Sam Jacobs

this code below works and searches for items in sheet2 and if any of them is found it lists it, if nothing found then it returns nothing found.  Now, i have to change the criteria.

The VBA needs to look for all items in sheet2  if even one of them is missing then it should return "one or more item is missing"  and only when it found all of the searched value then it should list it as shown in the screenshot.  

Thank you for your help.

User generated image
User generated image

Option Explicit


Function GetFolder(strPath As String) As String
Dim folder As FileDialog
Dim sItem As String
Set folder = Application.FileDialog(msoFileDialogFolderPicker)
Dim ret As Integer
With folder
    .Title = "Select a path to the .htm files"
    .AllowMultiSelect = False
    .InitialFileName = strPath
    If .Show = -1 Then
        GetFolder = .SelectedItems(1)
    Else
        GetFolder = ""
    End If
End With
Set folder = Nothing
End Function

'' You could also use

'  Dim basePath As String
'    Dim fd As FileDialog
'
'    Set fd = Application.FileDialog(msoFileDialogFolderPicker)
'    With fd
'        .Title = "Select Base Path"
'        .ButtonName = "Select"
'        .AllowMultiSelect = False
'        If .Show = -1 Then
'            basePath = .SelectedItems.item(1)
'        Else
'            Exit Sub
'        End If
'    End With
'  or simple basePath = InputBox("Enter your Path", "Base Path")
Public Sub Main()
       Dim basePath As String
    basePath = GetFolder(Application.ActiveWorkbook.path)
    If basePath = "" Then Exit Sub

    Dim results As Collection
    Set results = New Collection
    
        '// search words
    SearchHTMLFiles basePath, results
    
        '// display results
    Dim wb As Excel.Workbook
    Set wb = ThisWorkbook
    
    Dim ws As Excel.Worksheet
    Set ws = wb.Worksheets(1)
    
    Dim rng As Excel.Range
    Set rng = ws.Range("A2")
    
    Dim item As Variant
    For Each item In results
        rng.Value = item(0)
        rng.Offset(columnoffset:=1).Value = item(1)
        ws.Hyperlinks.Add Anchor:=rng, Address:=rng.Value
        Set rng = rng.Offset(rowoffset:=1)
    Next
End Sub

    '// recursive function looking for words
Private Function SearchHTMLFiles(ByVal path As String, ByRef results As Collection)
    Dim fso As Object       '// Scripting.fileSystemObject
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    Dim fld As Object       '// Scripting.folder
    Set fld = fso.GetFolder(path)
    
        '// lookfor HTML files
    Dim fl As Object        '// Scripting.File
    For Each fl In fld.Files
        If (fso.GetExtensionName(fl.Name) Like "htm*") Then
                '// HTML file processing
            Dim searchWords As Collection
            Set searchWords = searchWordsInHTMLFile(fl)
                '// build a collection of array with results
                '// 1st column is file path, 2nd column is the list of words found
           
           '// return "Nothing found" if no matches
            Dim foundWords As String
            If searchWords.Count > 0 Then
                foundWords = Concatenate(searchWords, ";")
            Else
                foundWords = "Nothing Found"
            End If
            results.Add Array(fl.path, foundWords)
            
        End If
    Next
    
        '// recursively call to look in all sub folders
    Dim subFld As Object        '// Scripting.folder
    For Each subFld In fld.SubFolders
        SearchHTMLFiles subFld.path, results
    Next
End Function

    '// concatenate all element in a collection, separated by provided separator
Private Function Concatenate(ByRef col As Collection, ByVal separator As String)
    Dim result As String
    Dim item As Variant
    For Each item In col
        If (result = vbNullString) Then
            result = item
        Else
            result = result & separator & item
        End If
    Next
    Concatenate = result
End Function

    '// retrieve the words list and search them
    '// return a collection of words found
'// Public Function searchWordsInHTMLFile(ByRef fl As Scripting.File) As Collection
Private Function searchWordsInHTMLFile(ByRef fl As Object) As Collection
    Dim wb As Excel.Workbook
    Set wb = ThisWorkbook
    
    Dim ws As Excel.Worksheet
    Set ws = wb.Worksheets(2)
    
    Dim rng As Excel.Range
    Dim lastrow As Long
    lastrow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
 Set rng = ws.Range("A2:A" & lastrow)    'Or Set rng = ws.Range(ws.Range("A2"), ws.Range("A2").End(xlDown))
    
    Dim lookupWords() As Variant
    lookupWords = rng.Value
    
    Set searchWordsInHTMLFile = searchWords(lookupWords, GetFileData(fl))
End Function

    '// return the whole content of a text file
'// Public Function GetFileData(ByRef fl As Scripting.File) As String
Private Function GetFileData(ByRef fl As Object) As String
    Const ForReading As Byte = 1
    Dim iStream As Object       '// Scripting.TextStream
    Set iStream = fl.OpenAsTextStream(ForReading)
    
    GetFileData = iStream.ReadAll
    iStream.Close
End Function

    '// search words in a single file
Private Function searchWords(ByRef words() As Variant, ByVal data As String) As Collection
    Dim rx As Object        '// VBScript_RegExp_55.RegExp
    Set rx = CreateObject("VBScript.RegExp")
    
    rx.Global = True
    rx.MultiLine = True
    
    Dim word As Variant
    For Each word In words
        If (rx.Pattern = vbNullString) Then
            rx.Pattern = word
        Else
            rx.Pattern = rx.Pattern & "|" & word
        End If
    Next
    
    Dim matches As Object       '// VBScript_RegExp_55.MatchCollection
    Set matches = rx.Execute(data)
    
    Dim wordsFound As Collection
    Set wordsFound = New Collection
    
    Dim match As Object     '// VBScript_RegExp_55.match
    For Each match In matches
        If Not (ExistInCollection(match.Value, wordsFound)) Then
            wordsFound.Add match.Value, match.Value
        End If
    Next
    Set searchWords = wordsFound
End Function

    '// helpers
Private Function ExistInCollection(ByVal key As String, ByRef col As Object) As Boolean
    ExistInCollection = ExistInCollectionByVal(key, col) Or ExistInCollectionByRef(key, col)
End Function

Private Function ExistInCollectionByVal(ByVal key As String, ByRef col As Object) As Boolean
On Error GoTo Error
    Dim item As Variant
    item = col(key)
    
    ExistInCollectionByVal = True
Exit Function
Error:
    ExistInCollectionByVal = False
End Function

Private Function ExistInCollectionByRef(ByVal key As String, ByRef col As Object) As Boolean
On Error GoTo Error
    Dim item As Variant
    Set item = col(key)
    
    ExistInCollectionByRef = True
Exit Function
Error:
    ExistInCollectionByRef = False
End Function

Open in new window

ASKER CERTIFIED SOLUTION
Avatar of Fabrice Lambert
Fabrice Lambert
Flag of France image

Link to home
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
Start Free Trial
Avatar of Skylar
Skylar

ASKER

Fabrice,

Thank you so very much!  this is great!

one small issue I faced, that if in Sheet2  if my search words are just one, then it will pop below error.   If my search words are more than one then it works.  Is it possible to fix that so that it works even if my list has one value to search?

User generated imageUser generated image
SOLUTION
Link to home
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
Start Free Trial
SOLUTION
Link to home
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
Start Free Trial
Avatar of Skylar

ASKER

Thanks.  I placed this code. and my code is still running for 5 minutes.  it looks like a endless loop

I replaced Dim lookupWords() As Variant

with
  Dim lookupWords() As Variant
    If (rng.Cells.Count = 1) Then
        ReDim lookupWords(0 To 0)
        lookupWords(0) = rng.value
    Else
        lookupWords = rng.value
    End If
Avatar of Skylar

ASKER

Thanks so much.  I found the culprit that caused the loop to go for one million rows.

it was in the  GetWordslist Function.     this one  Set rng = ws.Range(ws.Range("A2"), ws.Range("A2").End(xlDown))  Excel down was going all the way to the end of the workbook rows. and was causing a long loop.

I replaced it with
    Dim rng As Excel.Range
      Dim lastrow As Long
    lastrow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    Set rng = ws.Range("A2:A" & lastrow)

and it fixed the issue.

Private Function GetWordsList() As Collection
    Dim wb As Excel.Workbook
    Set wb = ThisWorkbook
    
    Dim ws As Excel.Worksheet
    Set ws = wb.Worksheets(2)
    
    Dim rng As Excel.Range
    Set rng = ws.Range(ws.Range("A2"), ws.Range("A2").End(xlDown))
    
    Dim words As Collection
    Set words = New Collection
    
    Dim cell As Excel.Range
    For Each cell In rng.Cells
        words.Add cell.Value
    Next
    Set GetWordsList = words
End Function

Open in new window

My statement computing the last row was wrong. I assumed the lookup words list was more than one cell, in that case, it was looking in the whole A column, that's 1048576 cells, ehence it took time.

Glad you fixed by yourself.
Avatar of Skylar

ASKER

Thanks Fabrice