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.
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.
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
ASKER CERTIFIED SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
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
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
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.
it was in the GetWordslist Function. this one Set rng = ws.Range(ws.Range("A2"), ws.Range("A2").End(xlDown)
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
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.
Glad you fixed by yourself.
ASKER
Thanks Fabrice
ASKER
I posted a new question. thanks
https://www.experts-exchange.com/questions/29125745/follow-question-on-solution-given-by-Fabrice-Lambert.html
https://www.experts-exchange.com/questions/29125745/follow-question-on-solution-given-by-Fabrice-Lambert.html
ASKER
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?