How to create a random sentence in word using VBA?
For example the code beneath created a sentence the cat sat on the mat1.
I would like to declare words in place of i.
Is it possible using VBA?
Sub Randomsentence()
Dim text As String
Dim s As String
MyText = "The cat sat on the"
i = Int(4 * Rnd())
Selection.TypeText (MyText)
Selection.TypeText (i)
End Sub
The following declafres an array and fills it with words. Then a random word is selected from the array and added to the sentence (shown as MsgBox for simplicity):
Sub Randomsentence()
Dim MyText As String
Dim s(5) As String
Dim i As Integer
s(1) = "mat"
s(2) = "floor"
s(3) = "roof"
s(4) = "car"
s(5) = "garage"
MyText = "The cat sat on the "
i = Int(5 * Rnd())
MsgBox MyText & s(i)
End Sub
A maybe nicer way to do that is to read the words from a file. I leave that to you as a nice excercise.
Related
I am trying to split data using VBA within word.
I have got the data using the following method
d = ActiveDocument.Tables(1).Cell(1, 1).Range.Text
This works and gets the correct data. Data for this example is
This
is
a
test
However, when I need to split the string into a list of strings using the delimiter as \n
Here is an example of the desired output
This,is,a,test
I am currently using
Dim dataTesting() As String
dataTesting() = Split(d, vbLf)
Debug.Print dataTesting(0)
However, this returns all the data and not just the first line.
Here is what I have tried within the Split function
\n
\n\r
\r
vbNewLine
vbLf
vbCr
vbCrLf
Word uses vbCr (ANSI 13) to write a "new" paragraph (created when you press ENTER) - represented in the Word UI by ¶ if the display of non-printing characters is activated.
In this case, the table cell content you show would look like this
This¶
is¶
a¶
test¶
The correct way to split an array delimited by a pilcro in Word is:
Dim d as String
d = ActiveDocument.Tables(1).Cell(1, 1).Range.Text
Dim dataTesting() As String
dataTesting() = Split(d, vbCr)
Debug.Print dataTesting(0) 'result is "This"
You can try this (regex splitter from this thread)
Sub fff()
Dim d As String
Dim dataTesting() As String
d = ActiveDocument.Tables(1).Cell(1, 1).Range.Text
dataTesting() = SplitRe(d, "\s+")
Debug.Print "1:" & dataTesting(0)
Debug.Print "2:" & dataTesting(1)
Debug.Print "3:" & dataTesting(2)
Debug.Print "4:" & dataTesting(3)
End Sub
Public Function SplitRe(Text As String, Pattern As String, Optional IgnoreCase As Boolean) As String()
Static re As Object
If re Is Nothing Then
Set re = CreateObject("VBScript.RegExp")
re.Global = True
re.MultiLine = True
End If
re.IgnoreCase = IgnoreCase
re.Pattern = Pattern
SplitRe = Strings.Split(re.Replace(Text, ChrW(-1)), ChrW(-1))
End Function
If this doesn't work, there may be strange unicode/Wprd characters in your Word doc. It may be soft breaks, for instance. You could try to not split with "\W+" in stead of "\s+". I cannot test this without your document.
Dim dataTesting() As String
dataTesting() = Split(d, vbLf)
Debug.Print dataTesting(0)
works fine and thank you very much for your example,
for why it have returned a whole array is because you have used 0 as index, in many programming languages 0 is the whole array, so the first element is ,
so in my case counting from 1 this perfectly split a string that I had troubles with.
To be more exact this is how it was used in my case
Dim dataTesting() As String
dataTesting() = Split(Document.LatheMachineSetup.Heads.Item(1).Comment, vbCrLf)
MsgBox (dataTesting(1))
And that comment is a multiline string.
Image
So this msg box returned exactly first line.
I have just started using visual basic and wanted to create a program that counted the number of times a word appeared. My plan was develop a program that analyses a sentence that contains several words without punctuation. When
a word in that sentence is input, the program identifies all of the positions where the word occurs in the sentence.
I started by making a code that counted the amount of spaces in a sentence but am now stuck.
Module Module1
Sub Main()
Dim Sentence As String
Dim SentenceLength As Integer
Dim Text As String
Console.WriteLine("ASK NOT WHAT YOUR COUNTRY CAN DO FOR YOU ASK WHAT YOU CAN DO FOR YOUR COUNTRY")
Console.WriteLine("Enter your word ") : Sentence = Console.ReadLine
Dim TextCounter As Integer = 0
Dim MainWord As String = Sentence
Dim CountChar As String = " "
Do While InStr(MainWord, CountChar) > 0
MainWord = Mid(MainWord, 1 + InStr(MainWord, CountChar), Len(MainWord))
TextCounter = TextCounter + 1
Text = TextCounter + 2
Console.WriteLine(Text)
Loop
Console.WriteLine(TextCounter)
Console.Write("Press Enter to Exit")
Console.ReadLine()
End Sub
End Module
A quick & dirty method is to split the string into an array of strings, then count how many times a word appears in it:
Dim words() As String = Sentence.Split(new char() {" ", ",", ".", ";"} ' add other punctuation as appropriate
Dim count = words.Count(Function(word) word = MainWord)
This uses the String.Split method to split the string each time a space is encountered. Then it uses the Enumerable.Count extension method to count the words that match a certain condition, that the word is equal to MainWord
To count substrings:
Dim count = UBound(Split("catty cat", "cat")) ' 2
To count words:
Dim countWords = Regex.Matches("catty cat", "\bcat\b").Count ' 1
I have a variable which contains five words.
Eg:- My name is Albert Einstein.
If the first word is "My" then it should be bold, else the word has to be deleted.
Hope the below code logic could help you to solve the problem:
Sub test1()
Debug.Print boldAndDeletion("Your name is Albert Einstein.")
End Sub
Function boldAndDeletion(inputString As String) As String
Dim splitStr1 As Variant
splitStr1 = Split(inputString, " ")
If splitStr1(0) = "My" Then
boldAndDeletion = "<b>My</b>" & Mid(inputString, 3)
Else
boldAndDeletion = Empty
End If
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
I am looking for some code that can search cell by cell in the 2nd column of a table for numbers and decimal points, cut them and paste them in the cell to the left whilst leaving the text behind.
For example:
1(tab space)Test
1.1(tab space)Test
1.1.1(tab space)Test
1.1.1.1(tab space)Test
Where the bullet points represent separate cells in different columns.
In all instances the numbers are separated from the text by a tab space "Chr9" (as indicated in the example)
Any help or useful snippets of code would much appreciated!
EDIT: I have some code that scans each cell in a column but I dont know the code to tell it to only cut numbers and decimal points up to the first tab space.
The Split function delivers what you are after. Sample code:
Dim inputString As String
Dim splitArray() As String
Dim result As String
inputString = "1 Test"
splitArray = Split(inputString, " ")
If(UBound(splitArray) >= 1) Then 'Making sure that it found something before using it
result = splitArray(1) 'Text
End If
inputString = "1.1 Test"
splitArray = Split(inputString, " ")
If(UBound(splitArray) >= 1) Then
result = splitArray(1) 'Text
End If
'etc.
UPDATE
Code delivering the functionality you want:
Dim splitArray() As String
Dim curTable As Table
Set curTable = ActiveDocument.Tables(1)
For Row = 1 To curTable.Rows.Count
With curTable
splitArray = Split(.Cell(Row, 2).Range.Text, " ")
If (UBound(splitArray) >= 1) Then
.Cell(Row, 2).Range.Text = splitArray(1)
.Cell(Row, 1).Range.Text = splitArray(0)
End If
End With
Next Row