As this is a code review request, some of my comments may be considered "best practices" by me and not by others (though most of my habits I've picked up from sites and reviews such as this one). Your code is successful already because it accomplishes the task for which you have designed. Most of the improvements I can suggest are in terms of software design and presentation.
- It is far less desirable to present a "wall of declarations" at the beginning of a method because it forces the reader to constantly refer back and forth between the logic and the declaration to figure out which variable is declared as what. It also makes it easier to declare a variable and then never use it. So... always declare your variables as close as practical to where they are first used.
- Always keep a wary eye out of repetitive-seeming steps or logic. When you find yourself cutting and pasting the same code with some tweaks to perform a nearly identical action, breaking it out into a separate method makes your logic much easier to read, PLUS it isolates your logic in a single location. This way if you have to modify that logic, you only do it once. In your code, you need to count the number of highlighted words of several different colors.
Breaking that out into its own Sub helps to keep the focus on how this is done:
Private Function CountFormattedWords(ByVal checkIndex As WdColorIndex, _
Optional ByRef checkDoc As Document = Nothing) As Long
'--- counts the number of words in the document highlighted with
' the given highlight color index
Dim thisDoc As Document
If checkDoc Is Nothing Then
Set thisDoc = ThisDocument
Else
Set thisDoc = checkDoc
End If
Dim checkWord As Variant
For Each checkWord In thisDoc.Words
If checkWord.HighlightColorIndex = checkIndex Then
CountFormattedWords = CountFormattedWords + 1
End If
Next checkWord
End Function
Notice the Optional ByRef checkDoc As Document = Nothing parameter. This is something I'll throw into the parameter list of a method based on long experience, knowing that I just might want to reuse this sub for a different Document. Clearly you can easily assume you're accessing the local document, but it might not always be the case.
Also, note that I used ThisDocument instead of ActiveDocument. The difference here is important. By specifying ThisDocument here, I'm telling the code to refer to the MS Word document in which the VBA code resides. If I used ActiveDocument, then I would be referring to whichever MS Word document is currently "on top" or actively being viewed/edited by the user. So in the case of this parameter, I'm giving myself the option to default it one way, but use it in a different way if I need to (see below).
So now the beginning of your logic can look like this
Dim testDoc As Document
Dim yellowErrors As Long
Dim blueErrors As Long
Dim greenErrors As Long
Dim totalErrors As Long
Set testDoc = ActiveDocument
yellowErrors = CountFormattedWords(wdYellow, testDoc)
blueErrors = CountFormattedWords(wdTurquoise, testDoc)
greenErrors = CountFormattedWords(wdBrightGreen, testDoc)
totalErrors = yellowErrors + blueErrors + greenErrors
You can note that here is where I slip in the reference to the ActiveDocument, which overrides the default of my parameter.
Avoid using Select. This is a major point when programming VBA for Excel, but less rigorous when using VBA in MS Word. With all the examples on the webz showing Select, you might find it hard to avoid. Since I started my VBA journey in Excel, I still stick with this rule though. So for using Find on a range to look for your word count, I created a Range variable called wordCount. Initially, you can see the range is set to encompass the entire document. After executing the Find however, this variable collapses to only the found text (in this case the text that is italic). A simple cast/conversion from String to Long gets me the integer word count.
'--- total word count should be the only text in the document
' using Italic format
Dim wordTotal As Long
Dim wordCount As Range
Set wordCount = testDoc.Content
With wordCount.Find
.Font.Italic = True
.Wrap = wdFindStop
.Execute
If .Found Then
wordTotal = CLng(wordCount)
Else
'--- do something if we didn't find it
MsgBox "ERROR! Can't find the Total Words count!"
Exit Sub
End If
End With
Your longest section of code is creating/appending the various details of the score to the end of the document. Again, it's pretty repetitive and pretty much the same. So... we have a separate sub to isolate the logic. This logic avoids using Select and simplifies some of what you were doing. Because it's nicely isolated, you can add any additional paragraph formatting you like here (and only do it once!).
Private Sub AppendScoreDetail(ByVal thisText As String, _
ByVal thisHighlight As WdColorIndex, _
Optional ByRef checkDoc As Document = Nothing)
Dim thisDoc As Document
If checkDoc Is Nothing Then
Set thisDoc = ThisDocument
Else
Set thisDoc = checkDoc
End If
Dim newText As Paragraph
Set newText = thisDoc.Content.Paragraphs.Add
With newText.Range
.Text = thisText
.Font.Italic = False
.Font.Underline = False
.Font.Bold = True
.Font.Name = "Arial Black"
.Font.Size = 11
.HighlightColorIndex = thisHighlight
.Paragraphs.Add
End With
End Sub
Now adding your score details is simply
'--- add totals and overall score at the end of the document
AppendScoreDetail "Incorrect: " & yellowErrors, wdYellow, testDoc
AppendScoreDetail "Omitted: " & blueErrors, wdTurquoise, testDoc
AppendScoreDetail "Added: " & greenErrors, wdBrightGreen, testDoc
AppendScoreDetail "Total: " & totalErrors, wdNoHighlight, testDoc
AppendScoreDetail "Score: " & Format$(score, "00.00%"), wdNoHighlight, testDoc
AppendScoreDetail "Grader's Name: ", wdNoHighlight, testDoc
I left the logic for copying your score to the clipboard largely intact since there is no real way to improve that. However, as I'm reading the code I don't understand why you're copying it to the clipboard or if a specific format is required. The comments you have in your code are redundant because the code itself is documenting what you're doing (especially if you continue to use descriptive variable names). The comments I appreciate are the ones that tell me why something is being done. You might always be the only person ever to look at your code, but I guarantee you'll forget why you did things a certain way three years from now.
Don't forget to re-enable Application.ScreenUpdating = True at the end of your logic.
For convenience, here is the entire module in a single block:
Option Explicit
'@Folder("Grading Macro")
Public Sub GradingMacro()
Application.ScreenUpdating = False
Dim testDoc As Document
Dim yellowErrors As Long
Dim blueErrors As Long
Dim greenErrors As Long
Dim totalErrors As Long
Set testDoc = ActiveDocument
yellowErrors = CountFormattedWords(wdYellow, testDoc)
blueErrors = CountFormattedWords(wdTurquoise, testDoc)
greenErrors = CountFormattedWords(wdBrightGreen, testDoc)
totalErrors = yellowErrors + blueErrors + greenErrors
'--- total word count should be the only text in the document
' using Italic format
Dim wordTotal As Long
Dim wordCount As Range
Set wordCount = testDoc.Content
With wordCount.Find
.Font.Italic = True
.Wrap = wdFindStop
.Execute
If .Found Then
wordTotal = CLng(wordCount)
Else
'--- do something if we didn't find it
MsgBox "ERROR! Can't find the Total Words count!"
Exit Sub
End If
End With
Dim score As Double
score = (wordTotal - totalErrors) / wordTotal
'--- add totals and overall score at the end of the document
AppendScoreDetail "Incorrect: " & yellowErrors, wdYellow, testDoc
AppendScoreDetail "Omitted: " & blueErrors, wdTurquoise, testDoc
AppendScoreDetail "Added: " & greenErrors, wdBrightGreen, testDoc
AppendScoreDetail "Total: " & totalErrors, wdNoHighlight, testDoc
AppendScoreDetail "Score: " & Format$(score, "00.00%"), wdNoHighlight, testDoc
AppendScoreDetail "Grader's Name: ", wdNoHighlight, testDoc
'--- but WHY are you copying the score to the clipboard (the code
' says what you're doing)
Dim clipboard As DataObject
Dim textToClip As String
Dim formattedScore As Variant
Dim pasteScore As Variant
formattedScore = Format$(score, "Percent")
pasteScore = Format$(score * 100, "Standard")
Set clipboard = New DataObject
textToClip = pasteScore
clipboard.SetText textToClip
clipboard.PutInClipboard
Application.ScreenUpdating = True
End Sub
Private Function CountFormattedWords(ByVal checkIndex As WdColorIndex, _
Optional ByRef checkDoc As Document = Nothing) As Long
'--- counts the number of words in the document highlighted with
' the given highlight color index
Dim thisDoc As Document
If checkDoc Is Nothing Then
Set thisDoc = ThisDocument
Else
Set thisDoc = checkDoc
End If
Dim checkWord As Variant
For Each checkWord In thisDoc.Words
If checkWord.HighlightColorIndex = checkIndex Then
CountFormattedWords = CountFormattedWords + 1
End If
Next checkWord
End Function
Private Sub AppendScoreDetail(ByVal thisText As String, _
ByVal thisHighlight As WdColorIndex, _
Optional ByRef checkDoc As Document = Nothing)
Dim thisDoc As Document
If checkDoc Is Nothing Then
Set thisDoc = ThisDocument
Else
Set thisDoc = checkDoc
End If
Dim newText As Paragraph
Set newText = thisDoc.Content.Paragraphs.Add
With newText.Range
.Text = thisText
.Font.Italic = False
.Font.Underline = False
.Font.Bold = True
.Font.Name = "Arial Black"
.Font.Size = 11
.HighlightColorIndex = thisHighlight
.Paragraphs.Add
End With
End Sub
Selection/Select? They can be removed most times, by just concating the expression before.Selectwith the part afterSelection.like' ActiveDocument.Range.Find.Font.Italic = True` Also you should try to sray DRY. Everytime you see repeating code with just minor diffs you should create s loop and a procedure that do tge same with less code. \$\endgroup\$ – ComputerVersteher Mar 10 '19 at 7:48