Sub CreateKeyWordDictionary(wsKeyWords As Worksheet, myKeyWordDictionary As Object)
'This creates a Dictionary of Unique KeyWords
'KEY = Unique Name (with tilde replacing spaces)
'ITEM = Unique Name before tilde replaced spaces
Dim iLastRowUsedInColumn As Long
Dim iRow As Long
Dim sValue As String
Dim sValueOriginal As String
'Get the last row used in Column 'A' in the 'Keywords Worksheet'
iLastRowUsedInColumn = wsKeyWords.Columns("A:A").Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
'Process each row in the Worksheet
'Read each value removing leading/trailing spaces
'Replace embedded spaces with Tilde '~'
'Replace Forward Slash with Tilde '~'
For iRow = 2 To iLastRowUsedInColumn
sValue = wsKeyWords.Cells(iRow, "A").Value
sValue = Trim(sValue)
sValueOriginal = sValue
sValue = Replace(sValue, " ", "~")
If myKeyWordDictionary.exists(sValue) = False Then
myKeyWordDictionary.Add sValue, sValueOriginal
End If
Next iRow
End Sub
Sub BuildPartNamesFromIndividualWords(wsScratch As Worksheet, myKeyWordDictionary As Object)
'This builds potential Part Names in the data area by replacing certain SPACES with tildes
'This is to make 'Part Names' in the 'Scratch' area match the names in the 'Dictionary'
Dim myRange As Range
Dim i As Long
Dim sPartName As String
Dim sPartNameLessTildes As String
'Create the replacement range
Set myRange = wsScratch.Columns("A:A")
For i = 0 To myKeyWordDictionary.Count - 1
sPartName = myKeyWordDictionary.keys()(i)
'Debug.Print i, sPartName
If InStr(sPartName, "~") > 0 Then
sPartNameLessTildes = Replace(sPartName, "~", " ")
Call LjmUniversalReplace(myRange, sPartNameLessTildes, sPartName)
'Debug.Print i, sPartName, sPartNameLessTildes
End If
Next i
'Clear object pointers
Set myRange = Nothing
End Sub
Sub RemoveExtraneousItems(wsExtraneousWordList As Worksheet, wsScratch As Worksheet)
'This removes extraneous words and punctuation from the 'Raw Data' Sheet
Dim myRange As Range
Dim iLastRowUsedInColumnInExtraneousWordColumn As Long
Dim iLastRowUsedInScratchSheet As Long
Dim iRow As Long
Dim sNew As String
Dim sOriginal As String
Dim sValue As String
'Create the replacement range
Set myRange = wsScratch.Columns("A:A")
iLastRowUsedInScratchSheet = wsScratch.Columns("A:A").Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
'Get the last row used in Column 'G' in the 'Extraneous Word Worksheet'
iLastRowUsedInColumnInExtraneousWordColumn = wsExtraneousWordList.Columns("G:G").Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
'Put a leading and trailing space in each data line on the Scratch Sheet
For iRow = 1 To iLastRowUsedInScratchSheet
sValue = Trim(wsScratch.Cells(iRow, "A").Value)
sValue = ASCII_SPACE & sValue & ASCII_SPACE
wsScratch.Cells(iRow, "A").Value = sValue
Next iRow
'Read each line from the 'Extraneous Word List'
'Replace each 'Extraneous Word' on the 'Scratch' Sheet with an ASCII SPACE
sNew = ASCII_SPACE
For iRow = 1 To iLastRowUsedInColumnInExtraneousWordColumn
sOriginal = Trim(wsExtraneousWordList.Cells(iRow, "G").Value)
If Left(sOriginal, 1) = "~" Then
sValue = Right(sOriginal, Len(sOriginal) - 1)
Else
sValue = ASCII_SPACE & sOriginal & ASCII_SPACE
End If
Call LjmUniversalReplace(myRange, sValue, sNew)
Next iRow
'Clear object pointers
Set myRange = Nothing
End Sub
Sub ReplaceTokenWithSynonym(wsSynonymList As Worksheet, wsScratch As Worksheet)
'This replaces words and phrases with Synonyms (e.g. to replace 'Cap' with 'Capacitor'.
'
'Occassionally this is used to create phrases that are consistent throughout
Dim myRange As Range
Dim iLastRowUsedInColumn As Long
Dim iRow As Long
Dim sNew As String
Dim sOriginal As String
Dim sValue As String
'Get the last row used in Column 'G' in the 'Extraneous Word Worksheet'
iLastRowUsedInColumn = wsSynonymList.Columns("I:I").Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
'Create the replacement range
Set myRange = wsScratch.Columns("A:A")
'Read each line from the 'Synonym Word List'
'Replace each 'Synonym Word' in the Sheet with it's synonym
For iRow = 2 To iLastRowUsedInColumn
sOriginal = Trim(wsSynonymList.Cells(iRow, "I").Value)
sValue = ASCII_SPACE & sOriginal & ASCII_SPACE
sNew = Trim(wsSynonymList.Cells(iRow, "J").Value)
sNew = ASCII_SPACE & sNew & ASCII_SPACE & ASCII_SPACE
Call LjmUniversalReplace(myRange, sValue, sNew)
'Debug.Print iRow, sValue, sNew
Next iRow
'Clear object pointers
Set myRange = Nothing
End Sub
Function GetMatchingFailureMode(wsKeyWords As Worksheet, sInputPartName As String, sSentenceFragment As String) As String
'This returns the 'Failure Mode' as a string if the 'Failure Mode' is Found
Dim r As Range
Dim a() As String
Dim i As Long
Dim iLastIndex As Long
Dim iMatchingTokenCount As Long
Dim iMaxMatchingTokenCount As Long
Dim bFoundMatchingFailureMode As Boolean
Dim bNeedMore As Boolean
Dim sAddress As String
Dim sFailureMode As String
Dim sFirstAddress As String
Dim sMatchingAddress As String
Dim sPartName As String
Dim sValue As String
'Create a local copy of the 'Part Name'
'Replace tildes in the 'Part Name' with spaces
sPartName = Trim(sInputPartName)
sPartName = Replace(sPartName, "~", " ")
'Debug.Print "'''''''''''''''''''''''''''''''"
'Debug.Print "Looking for failure mode for: " & sSentenceFragment
'Find the first Matching 'Part Name'
'Get the 'Address' of the first match
'Get the 'Failure Mode' associated with the 'Part Name'
Set r = LjmFindFirst(wsKeyWords, sPartName)
sFirstAddress = r.Address(False, False)
sFailureMode = Trim(r.Offset(0, 1).Value)
'Debug.Print r.Address(False, False), sFailureMode
bNeedMore = True
While bNeedMore
'Replace DASH and SLASH in the 'Failure Mode' string with spaces
sFailureMode = Replace(sFailureMode, "-", ASCII_SPACE)
sFailureMode = Replace(sFailureMode, "/", ASCII_SPACE)
'Determine if the ENTIRE 'Failure Mode' is contained VERBATIM in the 'Sentence Fragment'
If InStr(UCase(sSentenceFragment), UCase(sFailureMode)) > 0 Then
bNeedMore = False
bFoundMatchingFailureMode = True
sMatchingAddress = r.Address(False, False)
iMatchingTokenCount = iMatchingTokenCount + 1
iMaxMatchingTokenCount = iMaxMatchingTokenCount + 1
'Debug.Print "Matching Failure Mode = " & sFailureMode
Else
'Otherwise, Determine if the ENTIRE 'Failure Mode' is contained PIECE by PIECE in the 'Sentence Fragment'
iLastIndex = LjmParseString(sFailureMode, a)
'Process the 'Failure Mode' words one at a time
If iLastIndex >= 0 Then
For i = 0 To iLastIndex
'See if the next token is a PART Name
'If a PART Name, save the token as the FAILED part
'Remove the PART Name from the Sentence Fragment
sValue = UCase(Trim(a(i)))
'Debug.Print sValue
If InStr(UCase(sSentenceFragment), sValue) > 0 Then
'Debug.Print "Matched token for:" & sValue
'Increment the Matching Token Count
iMatchingTokenCount = iMatchingTokenCount + 1
'Increment the 'Max' Matching Token Count if the 'Max' value has been exceeded
If iMatchingTokenCount > iMaxMatchingTokenCount Then
iMaxMatchingTokenCount = iMatchingTokenCount
sMatchingAddress = r.Address(False, False)
End If
'If all the tokens in the 'Failure Mode' have been Matched, STOP - becuase there is a 100% match
If iMatchingTokenCount = iLastIndex + 1 Then
bNeedMore = False
bFoundMatchingFailureMode = True
sMatchingAddress = r.Address(False, False)
'Debug.Print "Matching Failure Mode = " & sFailureMode
End If
End If
Next i
End If
End If
'If there is NO MATCH, Get the Next 'Failure Mode' for this 'Part Name'
'STOP with NO MATCH, if all the 'Failure Modes' for this 'Part Name' have been processed
If bFoundMatchingFailureMode = False Then
'Find the next Matching 'Part Name'
'Get the 'Address' of the match
Set r = wsKeyWords.Columns("A").FindNext(After:=r)
sAddress = r.Address(False, False)
'if NOT the first address (2nd time around), Get the 'Failure Mode' associated with the 'Part Name'
'Otherwise, it is the end of data - exit
If sAddress <> sFirstAddress Then
sFailureMode = Trim(r.Offset(0, 1).Value)
'Debug.Print r.Address(False, False), sFailureMode
Else
bNeedMore = False
End If
End If
Wend
'Return the Matching 'Failure Mode' to the calling routine
'Return a message if 'Failure Mode' could not be found
If iMaxMatchingTokenCount > 0 Then
GetMatchingFailureMode = Trim(wsKeyWords.Range(sMatchingAddress).Offset(0, 1).Value)
Else
GetMatchingFailureMode = "Unable to Determine Failure Mode"
End If
End Function
Sub LjmUniversalReplace(myRange As Range, sOriginal As String, sNew As String)
'This performs a Universal replace (case insensitive) on a range
'
'NOTE: To match entire words and not words inside of words (e.g. 'the' and 'theme'), the 'Original'
' String SHOULD contain one leading and one trailing space.
' the 'New' String should also contain one leading and one trailing space.
myRange.Replace _
What:=sOriginal, _
Replacement:=sNew, _
LookAt:=xlPart, _
MatchCase:=False
End Sub
Function LjmParseString(InputString As String, ByRef sArray() As String) As Long
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' This parses a space delimited string into an array of tokens.
' Leading and trailing spaces are stripped from the string in the process.
'
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim i As Integer
Dim LastNonEmpty As Integer
Dim iSplitIndex As Integer
'Initialization
LastNonEmpty = -1
'Split the string into tokens
sArray = Split(InputString)
iSplitIndex = UBound(sArray)
'Remove the null tokens
For i = 0 To iSplitIndex
If sArray(i) <> "" Then
'Get rid of all the whitespace
LastNonEmpty = LastNonEmpty + 1
sArray(LastNonEmpty) = sArray(i)
End If
Next i
'Return the number of indices
LjmParseString = LastNonEmpty
End Function
Function LjmFindFirst(ws As Worksheet, sFindString As String) As Range
'This returns the address (as a string) of the first occurrence of a 'find string'
Dim r As Range
'Find the first occurence of the string
Set r = Nothing
Set r = ws.Columns("A").Find(What:=sFindString, _
After:=ws.Range("A1"), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False, _
SearchFormat:=False)
If Not r Is Nothing Then
'Save the found address as the return value as a string
Set LjmFindFirst = r
End If
'Clear the object pointer
Set r = Nothing
End Function
LinkBack URL
About LinkBacks
Register To Reply
Bookmarks