text hadling macros

shortman_alan · December 15th, 2008, 07:13 AM

hello, hello,

i am having great difficulty getting a macro to work that will look through a string of text, similar to this,
R0875F-FM3 ENTRY FEED TABLE LIFT HYDRAULIC CYLINDER O/HAUL
the string will be considered a high priority if the number at the front is above 1000 and low if it is not. this needs to be done as the regulatory activities are high priority and need to be grouped with the standard activities which have a number >1000. and from the calender the number of high, low and health and safety activities will be counted. the counting is already done by a macro but will not split up the activities as described. any help would be great, as i have wasted to much time on this already. cheers

i would also like to develop a macro that will prevent duplications of titles. for example when a title of "cutter" is entered as well as "cutters" or "end scraps" and "End Scraps" are entered they will be combined and the data that they are the heading for are kept under the same heading. i would imagine this would be kinda simple but i am just unsure how i would go about it as it would end up slowing down the code a fair bit using autofilters and such in the macro.

please email me with any help on [email protected] cheers! help would be much appreciated as i have been trying at this for what seems like forever!

shortman_alan · December 17th, 2008, 05:23 PM

would someone please be able to offer some help with this as i am really spending to much time trying to get something that gets close to doing this.
thank you

allenm · December 22nd, 2008, 10:02 AM

Is there always going to be letter(s) before the number? Do you know where in the string the number will always be? If not you will have to seek for it.

Assuming you want all number characters up to the first non-numeric character after the first number and you're unsure where the number starts or ends, The below function will extract the number:

Code:

Private Function GetUrgency(sFullText As String) As Long
  Dim sBuildNo As String, sChar As String, iCharOn As Long
  iCharOn = 1
  sChar = Left(sFullText,1)
'Locate first numeric character
  Do While iCharOn > Len(sFullText) And sChar <> "0" And Val(sChar) < 1
    iCharOn = iCharOn + 1
    sChar = Mid(sFullText,iCharOn,1)
  Loop
  Do While iCharOn > Len(sFullText) And (sChar = "0" Or Val(sChar) > 0)
    sBuildNo = sBuildNo & sChar
    iCharOn = iCharOn + 1
    sChar = Mid(sFullText,iCharOn,1)
  Loop
  GetUrgency = Val(sBuildNo)
End Function

Pass the string value to the function and it will return the 'extracted' number.

Now for testing if a string is contained within another is a little more complex. Goodness of fit algorithms can be extremely complex. There are plural forms, contractions, etc. that you'd have to code for including all permutations thereof. Best fit algorithms requiring word parsing are a bit much to delve into for a forum but If all you are looking for is plural of the whole phrase and ignoring of capitals, then something like this should work:

Code:

Private Function GoodFit(sFind As String, sWithin As String) As Boolean
  If Right(UCase(sFind),1) = "S" Then sFind = Left(sFind, Len(sFind) - 1) 'Removes ending S.  Detecting if this is a plural form word or not would require a lexicon check or a complex exhaustive set of compares
  if Right(UCase(sFind),2) = "'S" Then sFind = Left(sFind, Len(sFind) - 2) 'Removes apostraphe S
 
'Using UCase or LCase won't work if you're looking for contains, but work fine if the sWithin is supposed to be otherwise identical to sFind
  If UCase(sFind) = UCase(sWithin) Then GoodFit = True
 
'Using InStr would detect if the sought segment is anywhere within the sought within string.
'InStr(Starting-Character-Possition, Searched-String, String-Sought, Compare-Type)  Look it up in help for more information.
  If InStr(1, sWithin, sFind, vbTextCompare) > 0 then GoodFit = True
 
End Function

Proper fit algorithms are several dozen lines of code. Parsing for the most common will allow you to write code specific to your need in a few short lines instead.
Not sure how involved/specific your project requires you to be but this should hopefully at least get you started in the right direction.

Hope this helped,
Allen.

shortman_alan · December 28th, 2008, 08:21 AM

thankyou a lot for this code! i shall be giving it a shot tomorow when i go back to work. fingers crossed i can get the most of this project out of the way. thankyou. will deferentially be giving feedback!

shortman_alan · December 30th, 2008, 11:22 PM

hello again!
i have edited the code you gave me with the instr function in it to suit my application and have got it working for strings with 3 words in the string but not for strings containing 4 words!
i dont see how its being so weird with the 4 word strings?
i was wondering if you would be able to have a look at it and maybe be able to spot whats wrong with it? cheers

Code:

Public Function GoodFit(sFind As String, sWithin As String) As Boolean
Dim sFind2 As String, sFind3 As String, sFind4 As String, sFind5 As String
Dim spaces As Long, spaces2 As Long, spaces3 As Long, spaces4 As Long, sp1 As Long, sp2 As Long, sp3 As Long, sp4 As Long
    
    spaces = InStr(1, UCase(sFind), " ", vbTextCompare)
        sp1 = Val(spaces) - 1
    If spaces > 0 Then
        sFind2 = Trim(Left(UCase(sFind), sp1))
    ElseIf sp1 = Len(sFind) Or spaces = 0 Then
        GoTo Filter
    End If
    
    spaces2 = InStr(sp1, UCase(sFind), " ", vbTextCompare)
        sp2 = Val(Val(spaces2) + sp1)
    If spaces2 >= spaces And spaces2 > 0 Then
        sFind3 = Trim(Left(UCase(sFind), sp2))
    ElseIf sp2 = Len(sFind) + 1 Then
        GoTo Filter
    End If
    
    spaces3 = InStr(sp2, UCase(sFind), " ", vbTextCompare)
        sp3 = Val(Val(spaces3) + sp2)
    If spaces3 >= spaces2 And spaces3 > 0 Then
        sFind4 = Trim(Left(UCase(sFind), sp3))
    ElseIf sp3 = Len(sFind) Then
        GoTo Filter
    End If
    
    spaces4 = InStr(sp3, UCase(sFind), " ", vbTextCompare)
        sp4 = Val(Val(spaces4) + sp3)
    If spaces4 >= spaces3 And spaces4 > 0 Then
        sFind5 = Trim(Left(UCase(sFind), sp4))
    ElseIf sp4 = Len(sFind) Then
        GoTo Filter
    End If

Filter:

  If Right(UCase(sFind), 1) = "S" Then sFind = Left(sFind, Len(sFind) - 1) 'Removes ending S.  Detecting if this is a plural form word or not would require a lexicon check or a complex exhaustive set of compares
  If Right(UCase(sFind2), 1) = "S" Then sFind2 = Left(sFind2, Len(sFind2) - 1)
  If Right(UCase(sFind3), 1) = "S" Then sFind3 = Left(sFind3, Len(sFind3) - 1)
  If Right(UCase(sFind4), 1) = "S" Then sFind4 = Left(sFind4, Len(sFind4) - 1)
  If Right(UCase(sFind5), 1) = "S" Then sFind5 = Left(sFind5, Len(sFind5) - 1)
  'If Right(UCase(sFind), 2) = "'S" Then sFind2 = Left(sFind, Len(sFind) - 2) 'Removes apostraphe S
  If Right(UCase(sFind), 2) = "S." Then sFind = Left(sFind, Len(sFind) - 2) 'Removes S.
  If Right(UCase(sFind2), 2) = "S." Then sFind2 = Left(sFind2, Len(sFind2) - 2)
  If Right(UCase(sFind3), 2) = "S." Then sFind3 = Left(sFind3, Len(sFind3) - 2)
  If Right(UCase(sFind4), 2) = "S." Then sFind4 = Left(sFind4, Len(sFind4) - 2)
  If Right(UCase(sFind5), 2) = "S." Then sFind5 = Left(sFind5, Len(sFind5) - 2)
  If Right(UCase(sFind), 1) = "." Then sFind = Left(sFind, Len(sFind) - 1) 'Removes .
  If Right(UCase(sFind2), 1) = "." Then sFind2 = Left(sFind2, Len(sFind2) - 1)
  If Right(UCase(sFind3), 1) = "." Then sFind3 = Left(sFind3, Len(sFind3) - 1)
  If Right(UCase(sFind4), 1) = "." Then sFind4 = Left(sFind4, Len(sFind4) - 1)
  If Right(UCase(sFind5), 1) = "." Then sFind5 = Left(sFind5, Len(sFind5) - 1)
  
  'sFind2 <> "" And sFind3 <> "" And sFind4 <> "" And
    If sFind5 <> "" Then
        If InStr(1, UCase(sWithin), UCase(sFind2), vbTextCompare) > 0 _
        And InStr(spaces, UCase(sWithin), Trim(Right(UCase(sFind3), (Len(sFind3) - sp1))), vbTextCompare) _
        And InStr(spaces2, UCase(sWithin), Trim(Right(UCase(sFind4), (Len(sFind4) - sp2))), vbTextCompare) _
        And InStr(spaces3, UCase(sWithin), Trim(Right(UCase(sFind5), (Len(sFind5) - sp3))), vbTextCompare) _
        And Len(sFind) > 2 Then GoodFit = True
    ElseIf sFind4 <> "" Then
        If InStr(1, UCase(sWithin), UCase(sFind2), vbTextCompare) > 0 _
        And InStr(spaces, UCase(sWithin), Trim(Right(UCase(sFind3), (Len(sFind3) - sp1))), vbTextCompare) _
        And InStr(spaces2, UCase(sWithin), Trim(Right(UCase(sFind4), (Len(sFind4) - sp2))), vbTextCompare) _
        And Len(sFind) > 2 Then GoodFit = True
    ElseIf sFind3 <> "" Then
        If InStr(1, UCase(sWithin), UCase(sFind2), vbTextCompare) > 0 _
        And InStr(spaces, UCase(sWithin), Trim(Right(UCase(sFind3), (Len(sFind3) - sp1))), vbTextCompare) _
        And Len(sFind) > 2 Then GoodFit = True
    ElseIf sFind2 <> "" And Len(sFind3) = Len(sFind) Then
        If InStr(1, UCase(sWithin), UCase(sFind2), vbTextCompare) > 0 _
        And Len(sFind) > 2 Then GoodFit = True
    Else
        If InStr(1, UCase(sWithin), UCase(sFind), vbTextCompare) > 0 _
        And sFind <> "" Then GoodFit = True
    End If
  
 
End Function

i have gone down the road of splitting each string up into individual words as i found out it was needed in order to eliminate duplications of strings such as "trimmers choppers" and "trimmer chopper" where both words have plural or full stop.

any help would be great as i cant spend to long playing with this!
cheers, alan

shortman_alan · January 1st, 2009, 05:02 PM

would someone please be able to help me out with this?
cheers, alan

allenm · January 5th, 2009, 10:50 AM

For multiple words it would be easier to break the words out into an array first and work on them separately then reassemble the array in a way that lets you check specifically for identical match. Try the code below to find a sentence fragment within a whole sentence:

Code:

Private Function GoodFit(sFind As String, sWithin As String) As Boolean
 
  Dim aFindWords() As String, aWithinWords() As String, sSegment As String, sToFind As String, sTmp As Variant
  Dim iFindCount As Long, iWithinCount As Long, iStart As Long, iLoop As Long
  aFindWords() = GetWords(sFind)
  aWithinWords() = GetWords(sWithin)
 
'Reassembles seek into a sentence and does word count
  For Each sTmp In aFindWords()
    sToFind = sToFind & " " & sTmp
  Next
  sToFind = Trim(sToFind) 'Removes extra space
  iFindCount = UBound(aFindWords())
  iWithinCount = UBound(aWithinWords())
  If iWithinCount < iFindCount Then Exit Function
 
'Seeks for any match within starting with word iStart
  iStart = 0
  Do While iWithinCount - iStart >= iFindCount And Not GoodFit
    sTmp = ""
    For iLoop = 1 To iFindCount 'Creates a compare string that is the same number of words as the sToFind string
      sTmp = sTmp & " " & aWithinWords(iLoop + iStart)
    Next
    sTmp = Trim(sTmp)
    iStart = iStart + 1
    If UCase(sTmp) = UCase(sToFind) Then GoodFit = True
  Loop
 
End Function
 
Private Function GetWords(sPassed As String) As String()
 
'Returns an array of trimmed words back to calling function
  Dim aWords() As String, sWord As Variant, iCount As Long, aFinal() As String
  aWords = Split(sPassed, " ")
  For Each sWord In aWords
    sWord = Trim(sWord)
    If sWord <> " " And Len(sWord) > 0 Then 'returns only with non-blank non-null values
      iCount = iCount + 1
      If Right(sWord, 1) = "." Then sWord = Left(sWord, Len(sWord) - 1) 'Removes ending '.' but only 1. Loop if removing several
      If Right(UCase(sWord), 2) = "'S" Then sWord = Left(sWord, Len(sWord) - 2) 'Removes apostraphe S
      If Right(UCase(sWord), 1) = "S" Then sWord = Left(sWord, Len(sWord) - 1) 'Removes ending S
      ReDim Preserve aFinal(iCount)
      aFinal(iCount) = sWord
    End If
  Next
  GetWords = aFinal()
 
End Function

What this does:
1) Separates the sentences into an array of words splitting on spaces with the funciton GetWords. GetWords has also been coded to remove 1 trailing ".", "'s", and "s" from the word. It seems you also want to remove any . from the end of said word.
2) Adds Find sentence together back into what you're looking for
3) Assembles words 3 at a time to try and find an exact match of the modified find sentence. If found the array returns true.

This should be simpler and work for any number of words in the sentence segment being looked for and any size sentence you wish to find the segment within.

Hope this helps.
Allen

shortman_alan · January 7th, 2009, 05:30 PM

thank you a lot for this. it worked perfectly!

i would not have though you could do it this way. cheers, has shown me a lot