MY question would best be understood be the following example, my goal is to classify the following string into category if the string matches any one of the strings defined in those categories. For example,
dim test_str as string
test_str = "tomato"
If the test string tomato matches any one of the keywords (1) potato, (2) tomato and (3) spaghetti, then tomato will be classified as food.
I have a very inefficient way of doing this now, which involves using multiple strcomp, i.e.
if(strcomp(test_str, "potato", vbtextcompare) = 0 or _
strcomp(test_str, "tomato", vbtextcompare) =0 or _
strcomp(test_str, "spaghetti", vbtextcompare)=0 ) then
'label test str as "food"
However, if I have 10 keywords defined within "food", I would then need 10 strcomp statements, which would be tedious. Is there a better way to do this ?
I would simply store all the combinations in a string and check that the value is present with InStr:
Const food = "|potato|tomato|spaghetti|"
Dim test_str As String
test_str = "tomato"
If InStr(1, food, "|" & test_str & "|", vbTextCompare) Then
Debug.Print "food"
Else
Debug.Print "not food"
End If
Write a function that helps you
Function ArrayWordNotInText(textValue, arrayKeyword)
Dim i
ArrayWordNotInText = -1
For i = LBound(arrayKeyword) To UBound(arrayKeyword)
If Not StrComp(textValue, arrayKeyword(i), vbTextCompare) Then ArrayWordNotInText = i
Next i
End Function
If the return value = -1 ... no Match, >0 the index of the word
This is my first time posting; excuse my formatting. Have not been using VBA for too long but was able to piece this together.
Sub vinden4()
Dim EXCEPT() As String, a As Integer
EM = "no.replynoreply#ziggo.nl"
Exceptions = "no-Reply,noreply,nO.reply,"
EXCEPT = Split(Exceptions, ",")
For i = LBound(EXCEPT) To UBound(EXCEPT)
NOREPLY = InStr(1, EM, EXCEPT(i), vbTextCompare)
If NOREPLY > 0 Then
'CbEM.Value = True '~food~
EM = InputBox("NOREPLY E-MAILADRES", "Geef E-mailadres aan", EM)
'else
'CbEM.Value = False ~not food~
End If
Next i
MsgBox EM
End Sub
Hope this can help someone.
Related
For example "director of medicine" and I want it as "Director of Medicine not "Director Of Medicine" . I do not want letter "of" to be capitalise. Please help
The following VBA code would be a good start.
Option Base 1
Option Explicit
Function ProperIsh(inputString As String) As String
Dim result As String
Dim currWord As String
Dim idx As Integer
Dim wordPos As Integer
' List of words to revert to lower-case '
Dim lowerWords As Variant
lowerWords = Array("Of", "And", "It", "For", "Am", "The")
' Get proper-cased string with spaces on either end '
result = " " & WorksheetFunction.Proper(inputString) & " "
' Process each word to revert to lower-case '
For idx = 1 To UBound(lowerWords)
' Revert every one of that word with spaces on either side '
currWord = " " & lowerWords(idx) & " "
wordPos = InStr(result, currWord)
While wordPos > 0
result = Left(result, wordPos - 1) & LCase(currWord) & Mid(result, wordPos + Len(currWord))
wordPos = InStr(result, currWord)
Wend
Next
' Get rid of the spaces at the end '
ProperIsh = Mid(result, 2, Len(result) - 2)
End Function
And some test code for it:
Sub test()
MsgBox (ProperIsh("HELLO I AM THE LAW and i am the lower case law of everything"))
End Sub
What it does is to proper-case every word (upper-case first letter, everything else lower-case) then systematically revert any of the special words back to all lower-case.
It presupposes that space is the only separator but could be made more adaptable if that's the case.
The test code generates a message box with the expected output:
Hello I am the Law and I am the Lower Case Law of Everything
In order to use it in your expression, treat it as any other user defined function, such as with:
=ProperIsh(A1)
You can see it in operation with the following "screenshot" where column B uses the formula shown above:
A B
1 director of medicine Director of Medicine
2 I am the law I am the Law
3 Let slip the dogs of war Let Slip the Dogs of War
I used Rules for Capitalization in Titles of Articles as a reference to create a capitalization exceptions list.
Function TitleCase uses WorksheetFunction.ProperCase to preproccess the text. For this reason, I put in an exception for contractions because WorksheetFunction.ProperCase improperly capitalizes them.
The first word in each sentence and the first word after a double quotation mark will remain capitalized. Punctuation marks are also handled properly.
Function TitleCase(text As String) As String
Dim doc
Dim sentence, word, w
Dim i As Long, j As Integer
Dim arrLowerCaseWords
arrLowerCaseWords = Array("a", "an", "and", "as", "at", "but", "by", "for", "in", "of", "on", "or", "the", "to", "up", "nor", "it", "am", "is")
text = WorksheetFunction.Proper(text)
Set doc = CreateObject("Word.Document")
doc.Range.text = text
For Each sentence In doc.Sentences
For i = 2 To sentence.Words.Count
If sentence.Words.Item(i - 1) <> """" Then
Set w = sentence.Words.Item(i)
For Each word In arrLowerCaseWords
If LCase(Trim(w)) = word Then
w.text = LCase(w.text)
End If
j = InStr(w.text, "'")
If j Then w.text = Left(w.text, j) & LCase(Right(w.text, Len(w.text) - j))
Next
End If
Next
Next
TitleCase = doc.Range.text
doc.Close False
Set doc = Nothing
End Function
I am trying to remove words appearing in one string from a different string using a custom function. For instance:
A1:
the was why blue hat
A2:
the stranger wanted to know why his blue hat was turning orange
The ideal outcome in this example would be:
A3:
stranger wanted to know his turning orange
I need to have the cells in reference open to change so that they can be used in different situations.
The function will be used in a cell as:
=WORDREMOVE("cell with words needing remove", "cell with list of words being removed")
I have a list of 20,000 rows and have managed to find a custom function that can remove duplicate words (below) and thought there may be a way to manipulate it to accomplish this task.
Function REMOVEDUPEWORDS(txt As String, Optional delim As String = " ") As String
Dim x
'Updateby20140924
With CreateObject("Scripting.Dictionary")
.CompareMode = vbTextCompare
For Each x In Split(txt, delim)
If Trim(x) <> "" And Not .exists(Trim(x)) Then .Add Trim(x), Nothing
Next
If .Count > 0 Then REMOVEDUPEWORDS = Join(.keys, delim)
End With
End Function
If you can guarantee that your words in both strings will be separated by spaces (no comma, ellipses, etc), you could just Split() both strings then Filter() out the words:
Function WORDREMOVE(ByVal strText As String, strRemove As String) As String
Dim a, w
a = Split(strText) ' Start with all words in an array
For Each w In Split(strRemove)
a = Filter(a, w, False, vbTextCompare) ' Remove every word found
Next
WORDREMOVE = Join(a, " ") ' Recreate the string
End Function
You can also do this using Regular Expressions in VBA. The version below is case insensitive and assumes all words are separated only by space. If there is other punctuation, more examples would aid in crafting an appropriate solution:
Option Explicit
Function WordRemove(Str As String, RemoveWords As String) As String
Dim RE As Object
Set RE = CreateObject("vbscript.regexp")
With RE
.ignorecase = True
.Global = True
.Pattern = "(?:" & Join(Split(WorksheetFunction.Trim(RemoveWords)), "|") & ")\s*"
WordRemove = .Replace(Str, "")
End With
End Function
My example is certainly not the best code, but it should work
Function WORDREMOVE(FirstCell As String, SecondCell As String)
Dim FirstArgument As Variant, SecondArgument As Variant
Dim FirstArgumentCounter As Integer, SecondArgumentCounter As Integer
Dim Checker As Boolean
WORDREMOVE = ""
FirstArgument = Split(FirstCell, " ")
SecondArgument = Split(SecondCell, " ")
For SecondArgumentCounter = 0 To UBound(SecondArgument)
Checker = False
For FirstArgumentCounter = 0 To UBound(FirstArgument)
If SecondArgument(SecondArgumentCounter) = FirstArgument(FirstArgumentCounter) Then
Checker = True
End If
Next FirstArgumentCounter
If Checker = False Then WORDREMOVE = WORDREMOVE & SecondArgument(SecondArgumentCounter) & " "
Next SecondArgumentCounter
WORDREMOVE = Left(WORDREMOVE, Len(WORDREMOVE) - 1)
End Function
I have a list of full names in a column like for example:
Dave M. Butterworth
Dave M. Butterworth,II
H.F. Light jr
H.F. Light ,jr.
H.F. Light sr
Halle plumerey
The names are in a column. The initials are not limited to these only.
I want to extract the last name using a generic function. Is it possible?
Consider the following UDF:
Public Function LastName(sIn As String) As String
Dim Ka As Long, t As String
ary = Split(sIn, " ")
Ka = UBound(ary)
t = ary(Ka)
If t = "jr" Or t = ",jr" Or t = "sr" Or t = ",jr." Then
Ka = Ka - 1
End If
t = ary(Ka)
If InStr(1, t, ",") = 0 Then
LastName = t
Exit Function
End If
bry = Split(t, ",")
LastName = bry(LBound(bry))
End Function
NOTE:
You will have to expand this line:
If t = "jr" Or t = ",jr" Or t = "sr" Or t = ",jr." Then
to include all other initial sets you wish to exclude.You will also have to update this code to handle other exceptions as you find them !
Remove punctuation, split to an array and walk backwards until you find a string that does not match a lookup of ignorable monikers like "ii/jr/sr/dr".
You could also add a check to eliminate tokens based on their length.
Function LastName(name As String) As String
Dim parts() As String, i As Long
parts = Split(Trim$(Replace$(Replace$(name, ",", ""), ".", "")), " ")
For i = UBound(parts) To 0 Step -1
Select Case UCase$(parts(i))
Case "", "JR", "SR", "DR", "I", "II"
Case Else:
LastName = parts(i)
Exit Function
End Select
Next
End Function
I need a code that could give me a list of unique combinations from a set of elements in an array, something like this:
Say myArray contains [A B C]
So, the output must be:
A
B
C
A B
A C
B C
A B C
or
A B C
B C
A C
A B
A
B
C
either output is OK for me (Starts with 1 combination, followed by 2 combinations and ends with all combination OR vice versa).
The position of the letters are not critical and the order of letters within the same combination type is also not critical.
I'd found a suggestion by 'Dick Kusleika' in a thread: Creating a list of all possible unique combinations from an array (using VBA) but when I tried, it did not present me with the arrangement that I wanted.
I'd also found a suggestion by 'pgc01' in a thread: http://www.mrexcel.com/forum/excel-questions/435865-excel-visual-basic-applications-combinations-permutations.html and it gave me the arrangement that I wanted however, the combinations was not being populated in an array but it was being populated in excel cells instead, using looping for each combination.
So, I wanted the arrangement of combinations to be like what 'pgc01' suggested and being populated in an array as what 'Dick Kusleika' presented.
Anyone can help? Appreciate it.
Start from here:
Sub TestRoutine()
Dim inputt() As String, i As Long
Dim outputt As Variant
inputt = Split("A B C", " ")
outputt = Split(ListSubsets(inputt), vbCrLf)
For i = LBound(outputt) + 2 To UBound(outputt)
MsgBox i & vbTab & outputt(i)
Next i
End Sub
Function ListSubsets(Items As Variant) As String
Dim CodeVector() As Long
Dim i As Long
Dim lower As Long, upper As Long
Dim SubList As String
Dim NewSub As String
Dim done As Boolean
Dim OddStep As Boolean
OddStep = True
lower = LBound(Items)
upper = UBound(Items)
ReDim CodeVector(lower To upper) 'it starts all 0
Do Until done
'Add a new subset according to current contents
'of CodeVector
NewSub = ""
For i = lower To upper
If CodeVector(i) = 1 Then
If NewSub = "" Then
NewSub = Items(i)
Else
NewSub = NewSub & " " & Items(i)
End If
End If
Next i
If NewSub = "" Then NewSub = "{}" 'empty set
SubList = SubList & vbCrLf & NewSub
'now update code vector
If OddStep Then
'just flip first bit
CodeVector(lower) = 1 - CodeVector(lower)
Else
'first locate first 1
i = lower
Do While CodeVector(i) <> 1
i = i + 1
Loop
'done if i = upper:
If i = upper Then
done = True
Else
'if not done then flip the *next* bit:
i = i + 1
CodeVector(i) = 1 - CodeVector(i)
End If
End If
OddStep = Not OddStep 'toggles between even and odd steps
Loop
ListSubsets = SubList
End Function
Note we discard the first two elements of the output array.
I have 10 lines of array that are first name space last name space zip code. All the zip codes start with different numbers. Is there a way to replace the #1 in the indexof below so that it searches for any number character instead?
'open file
inFile = IO.File.OpenText("Names.txt")
'process the loop instruct until end of file
intSubscript = 0
Do Until inFile.Peek = -1 OrElse intSubscript = strLine.Length
strLine(intSubscript) = inFile.ReadLine
intSubscript = intSubscript + 1
Loop
inFile.Close()
intSubscript = 0
strFound = "N"
Do Until strFound = "Y" OrElse intSubscript = strLine.Length
intIndex = strLine(intSubscript).IndexOf("1")
strName = strLine(intSubscript).Substring(0, intIndex - 1)
If strName = strFullname Then
strFound = "Y"
strZip = strLine(intSubscript).Substring(strLine(intSubscript).Length - 5, 5)
txtZip.Text = strZip
End If
Loop
End Sub
use a regular expression.
Regular expressions allow you to do pattern matching on text. It's like String.IndexOf() with wildcard support.
For example, suppose your source data looks like this:
James Harvey 10939
Madison Whittaker 33893
George Keitel 22982
...and so on.
Expressed in English, the pattern each line follows is this:
the beginning of the string, followed by
a sequence of 1 or more alphabetic characters, followed by
a sequence of one or more spaces, followed by
a sequence of 1 or more alphabetic characters, followed by
a sequence of one or more spaces, followed by
a sequence of 5 numeric digits, followed by
the end of the string
You can express that very precisely and succintly in regex this way:
^([A-Za-z]+) +([A-Za-z]+) +([0-9]{5})$
Apply it in VB this way:
Dim sourcedata As String = _
"James Harvey 10939" & _
vbcrlf & _
"Madison Whittaker 33893" & _
vbcrlf & _
"George Keitel 22982"
Dim regex = "^([A-Za-z]+) +([A-Za-z]+) +([0-9]{5})$"
Dim re = New Regex(regex)
Dim lineData As String() = sourceData.Split(vbcrlf.ToCharArray(), _
StringSplitOptions.RemoveEmptyEntries )
For i As Integer = 0 To lineData.Length -1
System.Console.WriteLine("'{0}'", lineData(i))
Dim matchResult As Match = re.Match(lineData(i))
System.Console.WriteLine(" zip: {0}", matchResult.Groups(3).ToString())
Next i
To get that code to compile, you must import the System.Text.RegularExpressions namespace at the top of your VB module, to get the Regex and Match types.
If your input data follows a different pattern, then you will need to adjust your regex.
For example if it could be "Chris McElvoy III 29828", then you need to adjust the regex accordingly, to handle the name suffix.