For example, I have this string that reads "IRS150Sup2500Vup". It could also be "IRS250Sdown1250Vdown".
In my previous qn, I asked how to find a number between 2 characters. Now, I need to find the word up or down after the second S now. Since it appears between the character S and the number, how do I do it?
My code looks like this:
Dim pos, pos1,pos2 strString As String
pos = InStr(1, objFile.Name, "S") + 1
pos1 = InStr(pos, objFile.Name, "S")
pos2 = InStr(pos1, objFile.Name, ?)
pos1 returns the index of the second S. I am not sure what to place in ?
Using Regex.
Note: you need a reference to MS VBScripts Regular Expression library.
Dim r As VBScript_RegExp_55.RegExp
Dim sPattern As String, myString As String
Dim mc As VBScript_RegExp_55.MatchCollection, m As VBScript_RegExp_55.Match
myString = "IRS150Sup2500Vup"
sPattern = "\w?up+" 'searches for Sup, Vup, etc.
Set r = New VBScript_RegExp_55.RegExp
r.Pattern = sPattern
Set mc = r.Execute(myString)
For Each m In mc ' Iterate Matches collection.
MsgBox "word: '" & m.Value & "' founded at: " & m.FirstIndex & " length: " & m.Length
Next
For further information, please see:
How To Use Regular Expressions in Microsoft Visual Basic 6.0
Find and replace text by using regular expressions (Advanced)
Related
I have the following function that finds words in a string, for instance searching for don will find Don and not don't which is what I want:
"I don't know Don, what do you think?"
I however also find I need to look for words like race, races, racing. I would like to be able to search for rac* to cover all such variants rather than searching for each.
Is it possible to update the code to do this? Or does someone have any code that can solved this problem?
Function InStrExact(Start As Long, SourceText As String, WordToFind As String, _
Optional CaseSensitive As Boolean = False)
Dim x As Long, Str1 As String, Str2 As String, Pattern As String
If CaseSensitive Then
Str1 = SourceText
Str2 = WordToFind
Pattern = "[!A-Za-z0-9]"
Else
Str1 = UCase(SourceText)
Str2 = UCase(WordToFind)
Pattern = "[!A-Z0-9]"
End If
For x = Start To Len(Str1) - Len(Str2) + 1
If Mid(" " & Str1 & " ", x, Len(Str2) + 2) Like Pattern & Str2 & Pattern _
And Not Mid(Str1, x) Like Str2 & "'[" & Mid(Pattern, 3) & "*" Then
InStrExact = x
Exit Function
End If
Next
End Function
A simple modification is to add a wildcard to the end of your search string and match against all remaining characters in the original string. The change is to replace this line:
If Mid(" " & Str1 & " ", x, Len(Str2) + 2) Like Pattern & Str2 & Pattern _
with this:
If Mid(" " & Str1 & " ", x) Like Pattern & Str2 & Pattern & "*" _
This simply removes the restriction on the number of characters to be matched. If a wildcard is added to the end of the search word, it comes before the trailing pattern and so allows any number of additional characters. If there is no wildcard in the search word, then the trailing pattern still needs to come immediately after the search word and hence still requires an exact match.
Note that there will be an issue if the word you're searching for is the last word AND you add a wildcard. The length of Str2 then causes the function to stop searching too soon. So the complete solution is to also replace this line:
For x = Start To Len(Str1) - Len(Str2) + 1
with this:
For x = Start To Len(Str1)
There's no need to stop checking any earlier.
I'd go like follows:
Function InStrExact(startPos As Long, sourceText As String, wordToFind As String, _
Optional CaseSensitive As Boolean = False) As Long
Dim x As Long
Dim actualSourceText As String, actualWordToFind As String, Pattern As String
Dim word As Variant
actualSourceText = Replace(Mid(sourceText, startPos), ",", "")
If CaseSensitive Then
Pattern = "[A-za-z]"
Else
actualSourceText = UCase(actualSourceText)
actualWordToFind = UCase(wordToFind)
Pattern = "[A-Z]"
End If
For Each word In Split(actualSourceText, " ")
If CStr(word) Like actualWordToFind & Pattern Or CStr(word) = actualWordToFind Then
InStrExact2 = x + 1
Exit Function
End If
x = x + Len(word) + 1
Next
InStrExact = -1 '<--| return -1 if no match
End Function
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
So I'm completely new to VBA. I have a java-fetish so I'm not new to programming, however manipulating office documents just seemed easier with VBA.
Anyway, on topic:
I'm currently automating things in the company (This example is creating a contract). However, using Java, I always learned to make robust code and although the VBA code now works, I'm not happy with it because it requires a lot of 'friendliness' of the user. So my question is (I hope you don't mind), could you give me a nudge in the right direction to make my code way more robust?
Here's the code:
Function spaties(Name As String) As String
' Function used to ensure the length of a String (Working with Range)
Dim index As Integer
While (Len(Name) < 30)
Name = Name + " "
Wend
spaties = Name
End Function
Sub Macro3()
'
' Macro3 Macro
'
'
'ActiveDocument.Range(26101, 26102).Text = "d"
StartUndoSaver
Dim firma As String
firma = InputBox("Voor welke onderaannemer? (Zonder hoofdletters)" + Chr(10) + "(nicu, sorin of marius)")
Dim werf As String
werf = InputBox("Over welke Werf gaat het?")
Dim datum As String
datum = InputBox("Op welke datum spreekt het contract? (dd/mm/yyyy)")
With ActiveDocument
.Range(25882, 25899).Text = datum
ActiveDocument.Range(575, 605).Text = spaties(werf)
ActiveDocument.Range(1279, 1309).Text = spaties(werf)
End With
Select Case Len(firma)
Case 4
With ActiveDocument
.Range(26168, 26181).Text = "Nicu Dinita"
.Range(26062, 26088).Text = "Badi Woodconstruct SRL"
.Range(11359, 11371).Text = "Nicu Dinita"
End With
Case 5
With ActiveDocument
.Range(26168, 26181).Text = "Asavei Sorin"
.Range(26062, 26088).Text = "BELRO INTERIOR DESIGN SRL"
.Range(11359, 11371).Text = "Asavei Sorin"
End With
Case 6
With ActiveDocument
.Range(26168, 26181).Text = "Ivan Maricel"
.Range(26062, 26088).Text = "Solomon & Aaron Construct"
.Range(11359, 11371).Text = "Ivan Maricel"
End With
End Select
Dim prijs As String
Dim besch As String
Dim eenh As String
Dim hoev As Integer
hoev = InputBox("Hoeveel artikels zijn er?")
Dim index As Integer
index = 1
While (index <= hoev)
besch = InputBox("Beschrijving van het artikel (engels)")
prijs = InputBox("prijs van het artikel")
eenh = InputBox("Eenheid van het artikel")
With ActiveDocument
.Range(5701, 5702).Text = "" + vbTab + spaties2(besch, prijs, eenh) + Chr(10) + vbTab
End With
index = index + 1
Wend
With ActiveDocument.Sections(1)
.Headers(wdHeaderFooterPrimary).Range.Text = "Raes G. Schrijnwerken BVBA" + vbTab + vbTab + datum + Chr(10) + "Robert Klingstraat 5" + Chr(10) + "8940 Wervik"
.Footers(wdHeaderFooterPrimary).Range.Text = "Overeenkomst tot onderaanneming" + Chr(10) + "met betrekking tot:" + werf
.Footers(wdHeaderFooterPrimary).PageNumbers.Add PageNumberAlignment:=wdAlignPageNumberRight
End With
If firma = "sorin" Then
ActiveDocument.Range(254, 255).ImportFragment "Z:\Raes Netwerk DATA\professioneel\004 Sjablonen\belro.docx", False
Else
If firma = "nicu" Then
With ActiveDocument
.Range(254, 255).ImportFragment "Z:\Raes Netwerk DATA\professioneel\004 Sjablonen\Nicu.docx", False
End With
Else
If firma = "marius" Then
ActiveDocument.Range(254, 255).ImportFragment "Z:\Raes Netwerk DATA\professioneel\004 Sjablonen\Marius.docx", False
End If
End If
End If
ActiveDocument.PrintOut
ActiveDocument.PrintOut
End Sub
Function spaties2(artikel As String, prijs As String, eenh As String) As String
'Another function to ensure length of String
Dim index As Integer
Dim eind As String
eind = "" + artikel + vbTab + vbTab + prijs + "€/" + eenh
While (Len(eind) < 100)
eind = eind + " "
Wend
spaties2 = eind
End Function
As you can see, the code is very basic. And although it works, it's no good to deliver.
The two defined Functions are simply formatting the String of the user because obviously the name of something is not always the same length.
I'd like to cut out the Range properties, because in my opinion, that's what makes the program so sensitive to changes.
Any and all suggestions are welcome.
note: For the moment, the contract can have three different 'target parties' so that's why the Select Case statement is there. It's going to be completely useless if it should grow but for now it works.
Here's one:
sName = Left(sName & Space(30), 30)
And I think it's better to use bookmarks as placeholders instead of using Range(start, end)
How to change programmatically the text of a Word Bookmark
I think that your code needs some Trim's, in order to avoid mistaken spaces before and after the names (when you use some inputboxes, I mean).
And you need to verify input dates, too.
For string concatenation, use the ampersand (&) better than the plus sign (+), in order to avoid mistaken sums.
Instead of Chr(10) I have some recommendations in order to make your code more readable:
Chr(13) = vbCr
Chr(10) = vbLf
Chr(13) & Chr(10) = vbCrLf
Verify that the files you are indicating exist.
Using Range with numerical values is definitely not reliable. Bookmarks, as Tim suggests or content controls if this is Word 2007 or later. Content Controls are Microsoft's recommendation, going forward, but I don't see any particular advantage one way or the other for your purpose.
Looking at all the InputBox calls I have to wonder whether displaying a VBA UserForm for the input might not be better? All the input fields in one place, rather than flashing multiple prompts. You can validate for correct input before the UserForm is removed from the screen, etc.
I am trying to make a program that changes letters in a string and i keep running into the obvious issue of if it changes a value, say it changes A to M, when it gets to M it will then change that M to something else, so when i run the code to change it all back it converts it as if the letter was originally an M not an A.
Any ideas how to make it so the code doesnt change letters its already changed?
as for code ive just got about 40 lines of this (im sure theres a cleaner way to do it but im new to vba and when i tried select case it would only change one letter and not go through all of them)
Text1.value = Replace(Text1.value, "M", "E")
Try this:
Dim strToChange As String
strToChange = "This is my string that will be changed"
Dim arrReplacements As Variant
arrReplacements = Array(Array("a", "m"), _
Array("m", "z"), _
Array("s", "r"), _
Array("r", "q"), _
Array("t", "a"))
Dim strOutput As String
strOutput = ""
Dim i As Integer
Dim strCurrentLetter As String
For i = 1 To Len(strToChange)
strCurrentLetter = Mid(strToChange, i, 1)
Dim arrReplacement As Variant
For Each arrReplacement In arrReplacements
If (strCurrentLetter = arrReplacement(0)) Then
strCurrentLetter = Replace(strCurrentLetter, arrReplacement(0), arrReplacement(1))
Exit For
End If
Next
strOutput = strOutput & strCurrentLetter
Next
Here is the output:
Thir ir zy raqing ahma will be chmnged
Loop through it using the MID function. Something like:
MyVal = text1.value
For X = 1 to Len(MyVal)
MyVal = Replace(Mid(MyVal, X, 1), "M", "E")
X = X + 1
Next X
EDIT: OK upon further light, I'm gonna make one change. Store the pairs in a table. Then you can use DLookup to do the translation, using the same concept:
MyVal = text1.value
For X = 1 to Len(MyVal)
NewVal = DLookup("tblConvert", "fldNewVal", "fldOldVal = '" & Mid(MyVal, X, 1) & "")
MyVal = Replace(Mid(MyVal, X, 1), Mid(MyVal, X, 1), NewVal)
X = X + 1
Next X
Here's another way that uses less loops
Public Function Obfuscate(sInput As String) As String
Dim vaBefore As Variant
Dim vaAfter As Variant
Dim i As Long
Dim sReturn As String
sReturn = sInput
vaBefore = Split("a,m,s,r,t", ",")
vaAfter = Split("m,z,r,q,a", ",")
For i = LBound(vaBefore) To UBound(vaBefore)
sReturn = Replace$(sReturn, vaBefore(i), "&" & Asc(vaAfter(i)))
Next i
For i = LBound(vaAfter) To UBound(vaAfter)
sReturn = Replace$(sReturn, "&" & Asc(vaAfter(i)), vaAfter(i))
Next i
Obfuscate = sReturn
End Function
It turns every letter into an ampersand + the replacement letters ascii code. Then it turns every ascii code in the replacement letter.
It took about 5 milliseconds vs 20 milliseconds for the nested loops.
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.