I am writing my essays for university and I am not allowed to include words used in quotes toward my total word count. As Word does not have a feature to do this i was hoping that someone would be able to help me by creating a macro. I have used macros before, but I have very, very little experience into something as complex as this (if it's even that complex).
I already have something similar to work with citations throughout a document and so having both of these will be a great help. I will copy this code below so you can get a rough idea of what I need, except with quotes instead of citations.
So I was wondering if someone would be able to produce a macro that counted the number of words used in quotes throughout a document?
Sub CitationWordCount()
Dim Fld As Field, l As Long, StrTmp As String
For Each Fld In ActiveDocument.Fields
With Fld
If .Type = wdFieldCitation Then
StrTmp = .Result
l = l + UBound(Split(StrTmp, " ")) + UBound(Split(StrTmp, "-")) + 1
StrTmp = .Code.Text
l = l + Len(StrTmp) - Len(Replace(StrTmp, "\n", "\"))
End If
End With
Next
MsgBox "There are " & l & " words in citations in this document.", , "Citation Word Count"
End Sub
Paul Edstein (macropod) wrote a solution to this issue months ago on http://www.msofficeforums.com/word-vba/33866-count-words-between-quotation-marks.html
Sub Demo()
Application.ScreenUpdating = False
Dim i As Long, j As Long
With ActiveDocument
j = .ComputeStatistics(wdStatisticWords)
With .Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "[“" & Chr(34) & "]*[" & Chr(34) & "”]"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchWildcards = True
.Execute
End With
Do While .Find.Found
i = i + .ComputeStatistics(wdStatisticWords)
.Collapse wdCollapseEnd
.Find.Execute
Loop
MsgBox "This document contains " & j & " words ," & vbCr & _
"of which " & i & " (" & Format(i * 100 / j, "0.00") & _
"%) are in quotes."
End With
End With
Application.ScreenUpdating = True
End Sub
This will give you your total word count and the total amount of words in quotation marks. To get your total number, just subtract the words in quotes from the total words.
Related
I'm trying to search specific words in the selected/highlighted text. The result should show how much the word is used throughout the highlighted selected area.
I wrote a macro, but the total value of words shown is calculated through the entire document, not the selected part.
Sub CountWords()
'macros for counting specific words in the document
'to count the number of a specified word, this word needs to be highlighted
Dim rng As Range
Dim sWord As String
Dim i As Long
Dim sWord As String
Set rng = Selection.Range
Application.ScreenUpdating = False
sWord = InputBox( _
Prompt:="What word do you want to count?", _
Title:="Count Words", Default:="")
With rng.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = sWord
.Forward = True
.MatchWholeWord = True
.MatchWildcards = False
.Wrap = wdFindStop
Do While .Execute
i = i + 1
Loop
End With
Select Case i
Case 2 To 4
MsgBox "word " & Chr(171) & sWord & Chr(187) & " occurred in the document " & i & " times", _
vbInformation, "word count"
Case 1
MsgBox "word " & Chr(171) & sWord & Chr(187) & " occurred in the document " & i & " times", _
vbInformation, "word count"
Case Else
MsgBox "word " & Chr(171) & sWord & Chr(187) & " occurred in the document " & i & " times", _
vbInformation, "word count"
End Select
rng.Find.Text = ""
Application.ScreenUpdating = True
End Sub
I've tried a bunch of stuff, even other peoples codes. Every one of them counts specific words throughout the entire document.
For example:
Sub Demo()
Application.ScreenUpdating = False
Dim Rng As Range, sWord As String, i As Long
sWord = InputBox(Prompt:="What word do you want to count?", Title:="Count Words", Default:="")
With Selection
Set Rng = .Range
.Collapse wdCollapseStart
With .Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = sWord
.Forward = True
.MatchWholeWord = True
.MatchWildcards = False
.Wrap = wdFindStop
End With
Do While .Find.Execute
If .InRange(Rng) = False Then Exit Do
i = i + 1
Loop
End With
End With
Rng.Select
MsgBox "The word " & Chr(171) & sWord & Chr(187) & " occurred " & i & " times in the selected range.", _
vbInformation, "word count"
Application.ScreenUpdating = True
End Sub
I am trying to find all of the cells with a certain text of "0.118" in column 2 of my table and do a list of commands for that row
I am also trying to take the value from column 5 of that selected text found in that row and subtract the value I put in the input box for that row.
The problem I am having is that it only changes one of my found "0.118" and not all of them in each row.
And I can't figure out how to search for the column(5) of that selected row.
Any help would be greatly appreciated.
Thank you.
Sub ConvertTo_3MM()
Dim oTable As Table
Dim stT As Long, enT As Long
Dim stS As Long, enS As Long
With Selection.Find
.Forward = True
.MatchPhrase = True
.Execute FindText:="0.118"
End With
For Each oTable In ActiveDocument.Tables
Do While Selection.Find.Execute = True
stT = oTable.Range.Start
enT = oTable.Range.End
stS = Selection.Range.Start
enS = Selection.Range.End
If stS < stT Or enS > enT Then Exit Do
Selection.Collapse wdCollapseStart
If ActiveDocument.Tables.Count >= 1 Then
With ActiveDocument.Tables(1).Cell(nRow, 2).Range
.Text = "3 MM" & vbCrLf & "-" & vbCrLf & "6 MM"
End With
End If
Selection.MoveRight Unit:=wdCell
If ActiveDocument.Tables.Count >= 1 Then
With ActiveDocument.Tables(1).Cell(nRow, 3).Range
.InsertAfter Text:=vbCrLf & "-" & vbCrLf & "SHANK"
End With
End If
Selection.MoveRight Unit:=wdCell
Selection.MoveRight Unit:=wdCell
response = InputBox("Cut Length For 3 MM")
If ActiveDocument.Tables.Count >= 1 Then
With ActiveDocument.Tables(1).Cell(nRow, 5).Range
.Text = response & vbCrLf & "-" & vbCrLf & (column(5).value - response)
End With
End If
Selection.Find.Execute Replace:=wdReplaceAll
Loop
Selection.Collapse wdCollapseEnd
Next
Application.ScreenUpdating = True
End Sub
I would be very surprised if the code in your question actually does anything as it doesn't even compile.
Your code is rather a confused mess so I'm not entirely certain that I have correctly understood what you are attempting to do, but try this:
Sub ConvertTo_3MM()
Application.ScreenUpdating = False
Dim oTable As Table
Dim response As String
For Each oTable In ActiveDocument.Tables
With oTable.Range
With .Find
.Forward = True
.MatchPhrase = True
.Text = "0.118"
.Wrap = wdFindStop
.Execute
End With
Do While .Find.Found = True
.Text = "3 MM" & vbCr & "-" & vbCr & "6 MM"
With .Rows(1)
.Cells(3).Range.InsertAfter Text:=vbCr & "-" & vbCr & "SHANK"
response = Val(InputBox("Cut Length For 3 MM"))
With .Cells(5).Range
.Text = response & vbCr & "-" & vbCr & (Val(.Text) - response)
End With
End With
.Collapse wdCollapseEnd
.Find.Execute
Loop
End With
Next
Application.ScreenUpdating = True
End Sub
Thi may not be a solution, but I do see some problems:
You do:
For Each oTable In ActiveDocument.Tables
Then you do inside that loop:
Do While Selection.Find.Execute = True
but this Find will not be limited to the table of the For Each loop.
Though harmless, inside this Do While loop you do:
If ActiveDocument.Tables.Count >= 1 Then
but of course this is true because the For Each already determined there is at least 1 table.
I suggest you lookup the documentation of Find, rethink the logic and then run it step by step in the debugger to see what the code is doing.
Try this code:
Sub ConvertTo_3MM()
Dim oTable As Table, rng As Range
Dim nRow As Long, response As String
For Each oTable In ActiveDocument.Tables
With oTable
Set rng = .Range
Do
If rng.Find.Execute("0.118") Then
If rng.Information(wdEndOfRangeColumnNumber) = 2 Then
nRow = rng.Information(wdEndOfRangeRowNumber)
.Cell(nRow, 2).Range.Text = "3 MM" & vbCrLf & "-" & vbCrLf & "6 MM"
.Cell(nRow, 3).Range.InsertAfter Text:=vbCrLf & "-" & vbCrLf & "SHANK"
response = Val(InputBox("Cut Length For 3 MM"))
.Cell(nRow, 5).Range.Text = response & _
vbCrLf & "-" & vbCrLf & (Val(.Cell(nRow, 5).Range.Text) - response)
End If
Else
Exit Do
End If
rng.Collapse wdCollapseEnd
Loop
End With
Next
Application.ScreenUpdating = True
End Sub
Before
After
I'm trying to make the "number of occurrences" either be written in red or in bolded red. Can someone please point me in the right direction. I'm new to coding. This is a word-counter, and when 2+ words are found...it displays the number of words found at the bottom of the word document.
Sub a3()
Dim Word As String
Dim wcount As Integer
Word = InputBox("Search for a word")
If (Word <= "") Then
MsgBox ("Did not enter word")
End If
If (Word > "") Then
wcount = 0
With Selection
.HomeKey Unit:=wdStory
With ActiveDocument.Content.Find
.Text = Word
Do While .Execute
wcount = wcount + 1
Selection.MoveRight
Loop
End With
MsgBox ("The word: '" & Word & "' shows up " & wcount & " times in the document")
End With
End If
If (wcount <= 2) Then
ActiveDocument.Content.InsertAfter Text:=(vbCrLf & "Number occurrences: " & wcount)
Selection.Font.ColorIndex = wdRed
ElseIf (wcount <= 3) Then
ActiveDocument.Content.InsertAfter Text:=(vbCrLf & "Number occurrences: " & wcount)
Selection.Font.ColorIndex = wdRed
Selection.Font.Bold = True
Else
ActiveDocument.Content.InsertAfter Text:=(vbCrLf & "Number occurrences: " & wcount)
Selection.Font.ColorIndex = wdBlack
Selection.Font.Bold = False
End If
End Sub
Working with Word Range objects will help with this. Think of a Range like an invisible selection, except that code can work with multiple Range objects, while there can be only one Selection.
Assign the document's content to a Range, then perform the Find and extension on that. Then the formatting can also be applied to the Range. I've altered (but not tested) the code in the question to demonstrate.
In the last part, where text is written at the end of the document, the Range object is set to the entire document, then collapsed (think of it like pressing the right-arrow key with a selection). Then the new text is assigned to the range and formatting applied. Because the range will contain only the new text, the formatting is applied to that, only.
(Additional notes: I've changed the Word variable name to sWord because "Word" could be misunderstood to mean the Word application. I've also changed the comparison to check whether sWord contains something to Len(sWord) > 0 because the "greater than """ comparison is not guaranteed.)
Sub a3()
Dim sWord As String
Dim wcount As Integer
Dim rng as Word.Range
Set rng = ActiveDocument.Content
sWord = InputBox("Search for a word")
If (sWord <= "") Then
MsgBox ("Did not enter word")
End If
If (Len(sWord) > 0) Then
wcount = 0
With Selection
.HomeKey Unit:=wdStory
With rng.Find
.Text = sWord
Do While .Execute
wcount = wcount + 1
rng.Collapse wdCollapseEnd
Loop
End With
MsgBox ("The word: '" & sWord & "' shows up " & wcount & " times in the document")
End With
End If
Set rng = ActiveDocument.Content
rng.Collapse wdCollapseEnd
If (wcount <= 2) Then
rng.Text = (vbCrLf & "Number occurrences: " & wcount)
rng.Font.ColorIndex = wdRed
ElseIf (wcount <= 3) Then
rng.Text = (vbCrLf & "Number occurrences: " & wcount)
rng.Font.ColorIndex = wdRed
rng.Font.Bold = True
Else
rng.Text = (vbCrLf & "Number occurrences: " & wcount)
rng.Font.ColorIndex = wdBlack
rng.Font.Bold = False
End If
End Sub
There are many ways to do this, some of them are based on a preference for ranges or selections and also the structure of the Find statement. Here is my preference.
Sub a3()
Dim wrd As String
Dim wcount As Integer
Dim rng As Word.Range
wrd = InputBox("Search for a word")
If wrd = vbNullString Then
MsgBox ("Did not enter word")
Exit Sub
End If
Set rng = ActiveDocument.Content
wcount = 0
With rng.Find
.ClearFormatting
.Format = False
.Forward = True
.MatchWholeWord = True
.Text = wrd
.Wrap = wdFindStop
.Execute
Do While .found
wcount = wcount + 1
rng.Collapse Word.WdCollapseDirection.wdCollapseEnd
.Execute
Loop
End With
MsgBox ("The word: " & "" & wrd & "" & " shows up " & wcount & " times in the document")
ActiveDocument.Content.InsertParagraphAfter
Set rng = ActiveDocument.Content
rng.Collapse Word.WdCollapseDirection.wdCollapseEnd
rng.Text = "Number occurrences: " & wcount
If wcount < 3 Then
rng.Font.ColorIndex = wdRed
ElseIf wcount < 4 Then
rng.Font.ColorIndex = wdRed
rng.Font.Bold = True
Else
rng.Font.ColorIndex = wdAuto
rng.Font.Bold = False
End If
End Sub
(Note: See below for solution.)
I have been trying to retrieve the page numbers from pages that various headings reside on in a word document using VBA. My current code returns either 2 or 3, and not the correctly associated page numbers, depending on where and how I use it in my main Sub.
astrHeadings = docSource.GetCrossReferenceItems(wdRefTypeHeading)
For Each hds In astrHeadings
docSource.Activate
With Selection.Find
.Text = Trim$(hds)
.Forward = True
MsgBox hds & ":" & Selection.Information(wdActiveEndPageNumber), vbOKOnly
End With
Selection.Find.Execute
Next
docSource is a test document I have set up with 10 headings over 3 pages. I have the headings retrieved from the getCrossReferenceItems method in use later in my code.
What I am attempting is to loop through the results from the getCrossReferenceItems method and use each them in a Find object on docSource and from this ascertain what page the result is on. The page numbers will then be used in a string later in my code. This string plus page number will be added to another document which is created at the beginning of my main sub, everything else works a treat but this code segment.
Ideally what I need this segment to do is fill a second array with the associated page numbers from each Find result.
Problems Solved
Thanks Kevin you have been a great help here, I now have exactly what I need from the output of this Sub.
docSource is a test document I have set up with 10 headings over 3 pages.
docOutline is a new document which will act as a Table of Contents document.
I have had to use this Sub over Word's built-in TOC features because:
I have multiple documents to include, I could use the RD field to include these but
I have another Sub which generates custom decimal page numbering in each document 0.0.0 (chapter.section.page representative) that, for the whole document package to make sense, need to be included in the TOC as page numbers. There probably is another way of doing this but I came up blank with Word's built-in features.
This will become a Function to be included in my page numbering Sub. I am currently 3/4 of the way to completing this little project, the last quarter should be straightforward.
Revised and cleaned final Code
Public Sub CreateOutline()
' from http://stackoverflow.com/questions/274814/getting-the-headings-from-a-word-document
Dim docOutline As Word.Document
Dim docSource As Word.Document
Dim rng As Word.Range
Dim strFootNum() As Integer
Dim astrHeadings As Variant
Dim strText As String
Dim intLevel As Integer
Dim intItem As Integer
Dim minLevel As Integer
Dim tabStops As Variant
Set docSource = ActiveDocument
Set docOutline = Documents.Add
minLevel = 5 'levels above this value won't be copied.
' Content returns only the
' main body of the document, not
' the headers and footer.
Set rng = docOutline.Content
astrHeadings = docSource.GetCrossReferenceItems(wdRefTypeHeading)
docSource.Select
ReDim strFootNum(0 To UBound(astrHeadings))
For i = 1 To UBound(astrHeadings)
With Selection.Find
.Text = Trim(astrHeadings(i))
.Wrap = wdFindContinue
End With
If Selection.Find.Execute = True Then
strFootNum(i) = Selection.Information(wdActiveEndPageNumber)
Else
MsgBox "No selection found", vbOKOnly
End If
Selection.Move
Next
docOutline.Select
With Selection.Paragraphs.tabStops
'.Add Position:=InchesToPoints(2), Alignment:=wdAlignTabLeft
.Add Position:=InchesToPoints(6), Alignment:=wdAlignTabRight, Leader:=wdTabLeaderDots
End With
For intItem = LBound(astrHeadings) To UBound(astrHeadings)
' Get the text and the level.
' strText = Trim$(astrHeadings(intItem))
intLevel = GetLevel(CStr(astrHeadings(intItem)))
' Test which heading is selected and indent accordingly
If intLevel <= minLevel Then
If intLevel = "1" Then
strText = " " & Trim$(astrHeadings(intItem)) & vbTab & "1" & "." & "2" & "." & strFootNum(intItem) & vbCr
End If
If intLevel = "2" Then
strText = " " & Trim$(astrHeadings(intItem)) & vbTab & "1" & "." & "2" & "." & strFootNum(intItem) & vbCr
End If
If intLevel = "3" Then
strText = " " & Trim$(astrHeadings(intItem)) & vbTab & "1" & "." & "2" & "." & strFootNum(intItem) & vbCr
End If
If intLevel = "4" Then
strText = " " & Trim$(astrHeadings(intItem)) & vbTab & "1" & "." & "2" & "." & strFootNum(intItem) & vbCr
End If
If intLevel = "5" Then
strText = " " & Trim$(astrHeadings(intItem)) & vbTab & "1" & "." & "2" & "." & strFootNum(intItem) & vbCr
End If
' Add the text to the document.
rng.InsertAfter strText & vbLf
docOutline.SelectAllEditableRanges
' tab stop to set at 15.24 cm
'With Selection.Paragraphs.tabStops
' .Add Position:=InchesToPoints(6), _
' Leader:=wdTabLeaderDots, Alignment:=wdAlignTabRight
' .Add Position:=InchesToPoints(2), Alignment:=wdAlignTabCenter
'End With
rng.Collapse wdCollapseEnd
End If
Next intItem
End Sub
Private Function GetLevel(strItem As String) As Integer
' from http://stackoverflow.com/questions/274814/getting-the-headings-from-a-word-document
' Return the heading level of a header from the
' array returned by Word.
' The number of leading spaces indicates the
' outline level (2 spaces per level: H1 has
' 0 spaces, H2 has 2 spaces, H3 has 4 spaces.
Dim strTemp As String
Dim strOriginal As String
Dim intDiff As Integer
' Get rid of all trailing spaces.
strOriginal = RTrim$(strItem)
' Trim leading spaces, and then compare with
' the original.
strTemp = LTrim$(strOriginal)
' Subtract to find the number of
' leading spaces in the original string.
intDiff = Len(strOriginal) - Len(strTemp)
GetLevel = (intDiff / 2) + 1
End Function
This code is now producing (What it should be according to my headings specification found in test-doc.docx):
This is heading one 1.2.1
This is heading two 1.2.1
This is heading two.one 1.2.1
This is heading two.three 1.2.1
This is heading one.two 1.2.2
This is heading three 1.2.2
This is heading four 1.2.2
This is heading five 1.2.2
This is heading five.one 1.2.3
This is heading five.two 1.2.3
In Addition to this I have solved the ActiveDocument switching issue by using docSource.select and docOutline.Select statements instead of using.Active.
Thanks again Kevin, greatly appreciated :-)
Phil
It looks like Selection.Information(wdActiveEndPageNumber) will fit the bill, although it's in the wrong point of your code currently. Put this line after you execute the find, like so:
For Each hds In astrHeadings
docSource.Activate
With Selection.Find
.Text = Trim$(hds)
.Forward = True
End With
Selection.Find.Execute
MsgBox hds & ":" & Selection.Information(wdActiveEndPageNumber), vbOKOnly
Next
Addition for new question:
When you're setting the strFooter values, you're using ReDim to resize the array when you should be using ReDim Preserve:
ReDim Preserve strFootNum(1 To UBound(astrHeadings))
But, unless UBound(astrHeadings) is changing during the For loop in question, it'd probably be best practice to pull the ReDim statement outside of the loop:
ReDim strFootNum(0 To UBound(astrHeadings))
For i = 0 To UBound(astrHeadings)
With Selection.Find
.Text = Trim(astrHeadings(i))
.Wrap = wdFindContinue
End With
If Selection.Find.Execute = True Then
strFootNum(i) = Selection.Information(wdActiveEndPageNumber)
Else
strFootNum(i) = 0 'Or whatever you want to do if it's not found'
End If
Selection.Move
Next
For reference, the ReDim statement sets all the items in an array back to 0, whereas ReDim Preserve preserves all the data in the array before you resize it.
Also note the Selection.Move and the .Wrap = wdFindContinue lines - I think these were the root of the issue with my previous suggestions. The selection would be set to the final page because the find wasn't wrapping on any run of this other than the first run.
I wrote a little script that exports certain Excel cell values into Word. However, certain inserts need to be bold. And there doesn't seem to be an easy way to do this.
This code loops through the records and adds them to the Word document
Do While intRow < intTotalRows + 1
strTemp = " ;b;" & Range("G" & intRow).FormulaR1C1 & " " & Range("I" & intRow).FormulaR1C1 & ";e; "
If strTemp <> strCur Then
strCur = strTemp
.Content.Font.Bold = True
.Content.InsertAfter strCur
End If
.Content.Font.Bold = False
.Content.InsertAfter Range("A" & intRow).FormulaR1C1 & " - " & Range("C" & intRow).FormulaR1C1 & " " & Range("E" & intRow).FormulaR1C1 & " * "
intRow = intRow + 1
Loop
Turning on bold before inserting text and turning it off again afterwards seems like the most logical solution, so it does not work.
I then tried to find and replace the text, but that also did not work:
.Content.Find.ClearFormatting
With .Content.Find
.Text = ";b;" 'Look for
.Replacement.Text = ";bbb;" 'Replace with
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
.Content.Find.Execute Replace:=wdReplaceAll
Replace .InsertAfter with .TypeText. Inserting works like pasting whereas TypeText works like if you would actually type the text on the keyboard.