The macro below is supposed to pull the average words per sentence, then turn the text red in all sentences that are >=150% of that.
The problem is, it turns some shorter sentences red, as well. For example, it colored these sentences (edited to add: in the source doc, 150% of average length is 35 words):
31 words: The FSAIPs provide the basis for evaluation of the adequacy of the regulatory implementation of the design based on this assumed operational process and supports the preparation of prospective dose assessments.
29 words: (In accordance with 10 CFR 835.2, the equivalent dose rate criteria are applicable at 30 cm from the radiation source or 30 cm from any surface the radiation penetrates.)
(I'd share more examples, but this is a radiation control procedure on a Federal nuclear project, so I'm having to choose carefully.)
Those word counts for the sentences above are from the status bar at the bottom of the window. So Word appears to be counting the number of words differently depending on what part of Word is counting. I think.
Are there any suggestions on how to make the count more accurate, or at least the same for both situations? Oh, and a final note: it's not counting visible deleted words. It may be counting things like nonbreaking hyphens in some instances, but not in the ones shared above.
Sub Mark_Long()
'''''''''''''''''''
' Adapted from "Allen Wyatt's Word Tips, wordribbon.tips.net.
' I added to it so it pulls the avg sentence length from
' the readability stats, and only marks the sentences that are 150%
' of the average.
''''''''''''''''''''
Dim iMyCount As Integer
Dim iWords As Integer
Dim bTrackingAsWas As Boolean
If Not ActiveDocument.Saved Then
ActiveDocument.Save
End If
Set myRange = ActiveDocument.Content
wordval = myRange.ReadabilityStatistics(6).Value
bTrackingAsWas = ActiveDocument.TrackRevisions
'Turn off tracked changes
ActiveDocument.TrackRevisions = False
'Reset counter
iMyCount = 0
'Set number of words
iWords = (wordval * 1.5)
For Each MySent In ActiveDocument.Sentences
If MySent.Words.Count > iWords Then
MySent.Font.Color = wdColorRed
iMyCount = iMyCount + 1
End If
Next
'Restore tracked changes
ActiveDocument.TrackRevisions = bTrackingAsWas
'Report results
MsgBox iMyCount & " sentences longer than " & _
iWords & " words."
End Sub
you should use .Range.ComputeStatistics(wdStatisticWords) instead of .Words.Count.
The first returns a filtered value, the second an unfiltered
See:
http://www.vbaexpress.com/forum/archive/index.php/t-21723.html
The property .Words returns real words but also punctuation marks and paragraph marks. To get the real word count you can use this - a little bit weird - method.
Set dlg = Dialogs(wdDialogToolsWordCount)
For Each MySent In ActiveDocument.Sentences
MySent.Select
Set dlg = Dialogs(wdDialogToolsWordCount)
dlg.Execute
Count = dlg.Words
' Count is the number you are looking for
Next
You just simulate the 'Word Count' dialog.
Related
The initial problem that led me to learn VBA is as follows:
You have a table that can be up to 10,000 rows (several hundred pages) long in a Word document. The table has a title in the form of a paragraph above the first row. This title is styled such that it links to a Table of Contents (Style = "Caption"). The table must be broken at the last row on each page, and the title must be inserted before the new table but in a different style that is not linked to the Table of Contents(Style = "Caption Cont").
The first page will look like this:
The second page will look like this:
My first solution was relatively hackey and not at all elegant. I've managed to put together the following solution that works quite well. However, the initial process of determining the row number at which the table crosses pages is pretty slow due to the use of Range.Information. I'm wondering if there's a faster way to determine the bottom row on the page.
Putting the document into wdNormalView shaves off about a second per page, even with Application.ScreenUpdating = False...
The program requires that your cursor is somewhere inside the table, which is fine and not a functionality I wish to remove.
It currently does about 120 pages per minute, with the majority of the time being spent on determining the row to split at (i.e. splitNum). I'm sure it can be much faster with a different method of determining splitNum.
I CANNOT ADD AN ADDITIONAL ROW TO THE TABLE FOR THE PURPOSES OF USING "REPEAT HEADER ROWS".
It would violate regulations that are enforced in my industry, and a non-conforming document can be a huge hit to the company and future business
Code:
Sub tblSplit()
Dim timeCheck As Double
Application.ScreenUpdating = False
Application.ActiveWindow.View = wdNormalView
timeCheck = Time
On Error GoTo ErrH
Dim crossRef As Range, delRange As Range, tblR As Range, newTbl As Range
Dim tblNumField As Range, tblNum As String
Set tblNumField = Selection.Tables(1).Range
tblNumField.MoveStart wdParagraph, -1
tblNum = tblNumField.Words(2)
Set crossRef = Selection.Tables(1).Range
Set thisTbl = Selection.Tables(1).Rows(1).Range
Set tblR = Selection.Tables(1).Range
Insert cross-reference to title with style "Caption Cont"
crossRef.Move wdCharacter, -2
crossRef.InsertCrossReference ReferenceType:="Table", ReferenceKind:= _
wdOnlyCaptionText, ReferenceItem:=tblNum, InsertAsHyperlink:=True, _
IncludePosition:=False, SeparateNumbers:=False, SeparatorString:=" "
crossRef.Text = vbCr & " (Cont.)" & vbTab
crossRef.MoveStart wdCharacter, 1
crossRef.Style = "Caption Cont."
crossRef.Collapse wdCollapseStart
crossRef.InsertCrossReference ReferenceType:="Table", ReferenceKind:= _
wdOnlyLabelAndNumber, ReferenceItem:=tblNum, InsertAsHyperlink:=True, _
IncludePosition:=False, SeparateNumbers:=False, SeparatorString:=" "
crossRef.MoveEnd wdParagraph, 1
Delete duplicate title
Set delRange = crossRef.Duplicate
crossRef.MoveEnd wdParagraph, 1
crossRef.Copy
delRange.Text = vbNullString
Find row at which table spans two pages
Dim splitNum As Long, n As Long, i As Long, pageNum As Long
pageNum = tblR.Rows(1).Range.Information(wdActiveEndAdjustedPageNumber)
i = 15
Do
If tblR.Rows(i).Next.Range.Information(wdActiveEndAdjustedPageNumber) <> pageNum Then
splitNum = i
Exit Do
End If
i = i + 1
Loop Until i = 100 'arbitrary cap to prevent infinite loop
n = 1
Split and format
Do
DoEvents
'Split and format
tblR.Tables(n).Split (splitNum)
tblR.Tables(n).Rows.Last.Borders(wdBorderBottom).LineStyle = wdLineStyleSingle
'Paste the stuff
Set newTbl = tblR.Tables(n + 1).Range
newTbl.Move wdParagraph, -2
newTbl.Paste
newTbl.MoveEnd wdParagraph, 1
'Clear excess
newTbl.Paragraphs.Last.Range.Text = vbNullString
'Next
n = n + 1
Loop Until tblR.Tables(n).Rows.Count < splitNum
Restore state, report time, safe-exit and error handler set-up for debugging
Application.ActiveWindow.View = wdPrintView
Application.ScreenUpdating = True
MsgBox "Pages completed: " & n & vbCr & _
"Time (sec): " & DateDiff("s", timeCheck, Time) & vbCr & _
"Seconds per page: " & CDbl(DateDiff("s", timeCheck, Time)) / CDbl(n) & vbCr & _
"Pages per minute: " & n / DateDiff("s", timeCheck, Time) * 60
Exit Sub
ErrH:
Application.ScreenUpdating = True
Err.Raise Err.Number
Stop
End Sub
Here is a workaround that makes it seem as if the paragraph is separate from the table, but it's really the first row. I created a table of data with a couple hundred rows, then inserted a new row on the top of the table. The paragraph goes into this empty row at the top. Assuming the rest of the table has borders enabled, disable the top, left, and right borders for the first row only. Then enable "repeat header row". It looks like this when you're done:
and then the second page:
The fundamental problem you will have with any table-splitting approach is that it doesn't take account of the fact that Word uses the active printer driver to optimise the page layout.
Consequently, you may end up with what appears as the last row on a page when one printer is used ending up at the top of the next page when another printer is used. Alternatively, your headings might end up at the bottom of the page when a another printer is used.
As for your 'Caption'/'Caption Cont' Style machinations, that is all quite unnecessary if you create a full-with row for the caption at the top of the table and mark both the first and second rows as table header rows. Only the entry at the top of the table will appear in the Table of Contents. No code required.
This can be done in a much simpler way by inserting the copy of the table caption in a row at the top of the second part of a split table.
Split the table at the end of the first page as you already do. The rest of the activities now focus on the second part of the table.
For the second part of the table insert a single row at the top of the table.
Make the new single row a repeating table heading.
Paste the copy of the table caption in the row at the top of the second part of the table.
This will achieve the effect you are trying to achieve.
I had been in a situation in which I need to select particular text in two lines. I had been doing this by the following code:
Selection.Paragraphs(1).Range.Select
Selection.MoveRight Unit:=wdWord, Count:=2, Extend:=wdExtend
But the above code is not applicable to all four following scenarios. I'm in search of code which would output selection of first line and second line till 'comma'. I need code as simple as possible, kindly help.
Scenario 1
Infraestructura Energetica Nova SAB De CV
IENOVA* MM, Buy
Scenario 2
Infraestructura Energetica Nova SAB De CV
IENOVA13 MM, Sell
Scenario 3
Infraestructura Energetica Nova SAB De CV
IENOVA* MM
Scenario 4 Edited
Nova SAB
IENOVA MM
Illustration with Picture:
The following works with the two paragraphs as separate ranges. The first paragraph is picked up unaltered and used as the starting point for getting the second paragraph.
Using the Instr function, it determines whether a comma is present - Instr returns 0 if there is none, otherwise a positive number.
If there is no comma, the paragraph mark is cut off. It's not clear whether you want this Chr(13), if you do, just comment out that line and the paragraph is picked up with no changes.
If there is a comma, the Range is collapsed to its starting point, then extended to the position of the comma, minus 1 (leaves out the comma).
The two strings are then concatenated for debug.print. And then the endpoint of the first Range is extended to the end point of the second Range, so that you have one Range (if that's what you need - that's not clear).
Sub SelectInfo()
Dim rngLine1 As Word.Range
Dim rngLine2 As Word.Range
Dim isComma As Long
Set rngLine1 = Selection.Range.Paragraphs(1).Range
Set rngLine2 = rngLine1.Duplicate
rngLine2.Collapse (wdCollapseEnd)
Set rngLine2 = rngLine2.Paragraphs(1).Range
isComma = InStr(rngLine2.Text, ",")
If isComma = 0 Then
'No comma, assume we don't want the last paragraph mark...
rngLine2.MoveEnd wdCharacter, -1
Else
rngLine2.Collapse wdCollapseStart
rngLine2.MoveEnd wdCharacter, isComma - 1
End If
Debug.Print rngLine1.Text & rngLine2.Text
'Get a single Range instead of the string:
rngLine1.End = rngLine2.End
End Sub
Taking your question literally:
...I'm in search of code which would output selection of first line and second line till 'comma'.
You can make an adjustment to the 2nd line of your code as follows;
Selection.Paragraphs(1).Range.Select
Selection.MoveEndUntil ",", wdForward
What this does is moves the end of the selection forward until it finds ",".
If however, per your 'Scenarios', some of the selections may not contain a comma, the following will work:
Sub SelectionTest()
Dim mySel As String
With Selection
.Paragraphs(1).Range.Select
mySel = Selection
If InStr(1, mySel, ",") Then
.MoveEndUntil ",", wdForward
Else
.Extend "M"
.Extend "M"
End If
End With
End Sub
What this does is selects the paragraph, sets the string to the variable mySel and using the InStr function tests if the string contains a comma, if it does, it executes the same code as above, but if there is no comma, it extends the selection until the character "M" (upper case M) and then extends the selection again to the next "M".
As indicated in your comment the "MM" part of your text is a variable so:
Sub SelectionTest()
Dim mySel As String
With Selection
.Paragraphs(1).Range.Select
.MoveDown Unit:=wdLine, Count:=1, Extend:=wdExtend
mySel = Selection
If InStr(1, mySel, ",") Then
.Paragraphs(1).Range.Select
.MoveEndUntil ","
Else: Exit Sub
End If
End With
End Sub
What this does is selects the first paragraph and then extends the selection to the end of the 2nd line, sets selected text to the variable mySel and using the InStr function tests if the string contains a comma, if it does, it executes the same code as above, but if there is no comma, it keeps the 2 lines selected and that's it.
This keeps code shorter rather than having an ElseIf statement for each Country ("MM", "RO", "TI" etc) but does rely on no text after the Country code. Otherwise follow the previous part of the answer and repeat the ElseIf for each Country variable.
I tested this on all of your scenarios (by copy/pasting your scenario paragraphs into word) and each one resulted the same as your 'target selection' as long as the cursor was at the start of the required paragraph when the code was run.
Alternatively you can omit the part specifying the comma and just use (perhaps adjust as required and put this within an if statement to allow for your variables):
With Selection
.Paragraphs(1).Range.Select
.Extend "M"
.Extend "M"
End With
These codes will work based on what you've asked and provided in your question but may not be the most universal code in it's current form.
There is some more info on the functions and methods used in the below links:
Selection.MoveEndUntil
Selection.Extend
InStr
Selection.MoveDown
I have a range (rng) which has the word "means" somewhere in it. I'm trying to determine if a word two words before "means" is underlined but can't quite figure out how.
Here's what my rng.Text is (note the brackets indicate the underlined text)
"[Automobile] - means a car that isn't a bus but can be an SUV"
Sometimes, it is "The way you have to go about it is with the various means of thinking".
The first one is a definition, since it has "means" preceeded by an underlined word. The second example is NOT a definition.
I'm trying to get my macro to look to 2 word before "means", but can't quite figure out how.
I am able to figure how many characters it is by this:
Dim meansLoc&
meansLoc = instr(rng.Text, "means")
Then, I can test If rng.Characters(meansLoc-9).Font.Underline = wdUnderlineSingle, but I run into problems if my defined word is only say 3 characters ("Dad - means a father", would error our since there means' index is 7, and 7-9 = -2). This is why I'd like to use words. (I can use one or two words before "means").
How can I return the character index of "means" in my rng. How do I get the "word index" (i.e. 2) from my rng?
Both Characters and Words are ranges, so one approach would be to compare the Start of the Character's range with each Word in the rng, e.g. you could start with
' assumes you have already declared and populated rng
Dim bDefinition As Boolean
Dim i as Integer
Dim meansLoc as Integer
Dim meansStart as Integer
meansLoc = instr(rng.Text,"means")
meansStart = rng.Characters(meansLoc).Start
bDefinition = False
For i = 1 To rng.Words.Count
If rng.Words(i).Start = meansStart Then ' i is your Word index (i.e. 3, not 2!)
If i > 2 Then
If rng.Words(i - 2).Font.Underline = wdUnderlineSingle Then
Debug.Print "Looks like a definition"
bDefinition = True
Exit For
End If
End If
End If
Next
If Not bDefinition Then
Debug.Print "Couldn't see a definition"
End If
Just bear in mind that what Word considers to be a "word" may be different from your normal understanding of what a "word" is.
I have this data in Excel:
But one of my clients needs it summarize per item in detail.
So above data needs to be converted to:
This way, client can analyze it per tracking and per item.
The text format is not really uniform since it is entered manually.
Some users use Alt+Enter to separate items. Some uses space and some doesn't bother separating at all. What's consistent though is that they put hyphen(-) after the item then the count (although not always followed by the number, there can be spaces in between). Also if the count of that item is one(1), they don't bother putting it at all (as seen on the tracking IDU3004 for Apple Juice).
The only function I tried is the Split function which brings me closer to what I want.
But I am still having a hard time separating the individual array elements into what I expect.
So for example, IDU3001 in above after using Split (with "-" as delimiter) will be:
arr(0) = "Apple"
arr(1) = "20 Grape"
arr(2) = "5" & Chr(10) & "Pear" ~~> Just to show Alt+Enter
arr(3) = "3Banana"
arr(4) = "2"
Of course I can come up with a function to deal with each of the elements to extract numbers and items.
Actually I was thinking of using just that function and skip the Split altogether.
I was just curious that maybe there is another way out there since I am not well versed in Text manipulation. I would appreciate any idea that would point me to a possible better solution.
I suggest using a Regular Expression approach
Here's a demo based on your sample data.
Sub Demo()
Dim re As RegExp
Dim rMC As MatchCollection
Dim rM As Match
Dim rng As Range
Dim rw As Range
Dim Detail As String
' replace with the usual logic to get the range of interest
Set rng = [A2:C2]
Set re = New RegExp
re.Global = True
re.IgnoreCase = True
re.Pattern = "([a-z ]+[a-z])\s*\-\s*(\d+)\s*"
For Each rw In rng.Rows
' remove line breaks and leading/trailing spaces
Detail = Trim$(Replace(rw.Cells(1, 3).Value, Chr(10), vbNullString))
If Not Detail Like "*#" Then
' Last item has no - #, so add -1
Detail = Detail & "-1"
End If
' Break up string
If re.Test(Detail) Then
Set rMC = re.Execute(Detail)
For Each rM In rMC
' output Items and Qty's to Immediate window
Debug.Print rM.SubMatches(0), rM.SubMatches(1)
Next
End If
Next
End Sub
Based on your comment I haved assumed that only the last item in a cell may be missing a -#
Sample input
Apple Juice- 20 Grape -5
pear- 3Banana-2Orange
Produces this output
Apple Juice 20
Grape 5
pear 3
Banana 2
Orange 1
The aim of the following is to automate a spelling test process.
Each word in the test has an attached word list of between 1 and 11 eleven words that students need to practise if they are unable to spell the word correctly.
The VBA below currently generates a list of words for an individual specified in cell C2 however I would like the VBA to generate a list of words for all available individuals. I am thinking that I will need a 'For... Each' loop but I'm not quite sure how to implement.
Ideally, I would like words to be outputted to a worksheet which contains the following info:
A summary at the top which outlines students who have completed the test and the number of words they have been allocated. The summary also highlights students who have less than 10 words need to complete the next test immediately and students who have more than 10 but less than 50, need to complete the next test in the near future.
A section for individual students who have more than zero words which specifies: first name, surname, number of words and date. Words should appear in a grid which is 12 columns wide and the necessary number of rows high.
Sub GenerateSpellingWords()
Dim nameColumnNumber As Integer
Dim namePerson As String
Dim WS As Worksheet
nameColumnNumber = Sheets("Dashboard").Range("I2").Value
namePerson = Sheets("Dashboard").Range("C2").Value
Sheets.Add.Name = namePerson
Range("A1:L1").Select
Selection.Merge
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
ActiveCell.FormulaR1C1 = namePerson & "'s Spelling Words"
Rows("1:1").RowHeight = 27.75
Range("A1:L1").Select
Selection.Font.Bold = True
With Selection.Font
.Size = 14
End With
Sheets("Dashboard").Select
Rows("4:34").Select
Selection.AutoFilter
Sheets("Dashboard").Range("$A$4:$W$34").AutoFilter Field:=nameColumnNumber, Criteria1:="N"
Sheets("Dashboard").Range("C5:N34").Select
Selection.Copy
Sheets(namePerson).Select
Range("A2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Cells.Replace What:="0", Replacement:="'", LookAt:=xlPart, SearchOrder _
:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
Range("A2").Select
Sheets("Dashboard").Select
Range("C2").Select
Selection.AutoFilter
End Sub
I agree with D Mason, it is impossible to deduce exactly what you want from your specification. You supply a lot of detail but much detail needed by a programmer is missing. It would be difficult to get the missing parts of your design via an exchange of comments so I have decided to guess what you seek. If you study my specification and use F8 to single step through my code you should be able to discover how I achieve particular effects. You can then use your enhanced VBA knowledge to write the macros you want.
I am guessing that most of your existing code was created using the Macro Recorder. This is a good way of learning the syntax of an unfamiliar statement but is not a good way of learning VBA. The Recorder does not know your intentions so records each action as it happens. The result is syntactically correct VBA but not good VBA. By studying my macros you will enhance your understanding of VBA but you must spend some time on a systematic study.
Search the web for “Excel VBA Tutorial” and you will find many. Try a few and pick one that matches your learning style. A local college may offer short courses that cover the basics. I prefer books. I visited a large library and spent half-an-hour looking through their VBA Primers. I borrowed the three I liked most to try out at home. I then bought my favourite. I have it on my shelf and I still refer to it from time to time; good investment. The time you spend learning VBA will quickly repay it.
I deduce from your code that columns A to O of worksheet “Dashboard” contain your word lists. Perhaps column A contains a list number but no matter. Columns P, Q and so on are for individual students and contain “N” if that student has not yet mastered that row’s list. Currently rows 4 to 34 contain word lists but no doubt you will add more later. This is my Dashboard:
I have filled the word list area with formulaic data because that helps with testing the code. I do not know how you use rows 1 to 3 and have left them blank.
I have created a new worksheet “Students” which I initialised to:
I envisage columns C, D and so on being used for other student information but I have only used a “Name” and a “To do” column. I will explain the “To do” column later.
I ran macro AddNewStudent(). Worksheets “Dashboard” and “Students” changed as shown below. At the bottom of worksheets “Dashboard”, you can see the worksheets that have been created. I also show worksheet “George”.
If a new student joins your class, add their name to worksheets “Students” and rerun AddNewStudent().
Macro OutputWordLists() outputs the word lists for each student. You do not say but I assume you manually remove Ns from worksheet “Dashboard” as students demonstrate their mastery of the various word lists. From time to time you will rerun OutputWorklists() to update the statistics in worksheet “Students” and to produce new word lists for your students which you could print and distribute if appropriate.
I have updated worksheet “Dashboard” to reflect the students’ progress and I have just run AddNewStudent() to create a worksheet for new student Frederick. I have also added some more word lists at the bottom.
I ran OutputWordLists(). This has no effect on worksheet “Dashboard”. Worksheet “Students” has been updated to record the current number of Ns in the “To do” column. You express an interest in other statistics but I do not understand what you want. I hope I have given you enough techniques to allow you to decide how to add the code to calculate these statistics. Worksheet “George” has been updated for the next 10 word lists that he has to master. I have only included 10 word lists because I thought listing the lot would be too intimidating.
As I said at the beginning, you should single step through my macros and study what they do. Come back with questions if necessary but the more you can discover on your own, the faster you will develop your VBA skills. I hope this gives you enough ideas to progress.
I should perhaps mention that these macros are development macros and include Debug.Print and Debug.Assert statements. I would never include such statements in a production macro that I was distributing to others but they are invaluable aids during development.
Good luck and welcome to the joys of programming.
Option Explicit
' Use data type "Long" rather than "Integer". "Integer" specifies a 16-bit
' number which requires special processing on a 32-bit computer.
' Using constants makes the code easier to understand and easier to maintain.
Const ColDshBrdFirstName As Long = 16
Const ColStdLstName As Long = 1
Const ColStdLstToDo As Long = 2
Const RowDshBrdFirstWordList As Long = 4
Sub AddNewStudent()
Dim ColDshBrdCrnt As Long
Dim Found As Boolean
Dim InxWsht As Long
Dim Rng As Range
Dim RowDshBrdLast As Long
Dim RowStdLstCrnt As Long
Dim StudentName As String
' Speeds up the macro and stops the screen flashing as new worksheets are created
Application.ScreenUpdating = False
' Identify the last row containing a word list
With Worksheets("Dashboard")
Set Rng = .Cells.Find("*", .Range("A1"), xlFormulas, , xlByRows, xlPrevious)
If Rng Is Nothing Then
' No data found
Debug.Assert False
Exit Sub
Else
RowDshBrdLast = Rng.Row
Debug.Print "Last word list on row " & RowDshBrdLast
End If
End With
RowStdLstCrnt = 2 ' Assume one header row
Do While True
' Extract new name for student list
StudentName = Worksheets("Students").Cells(RowStdLstCrnt, ColStdLstName).Value
If StudentName = "" Then
' Name list exhausted
Exit Do
End If
' Look for existing worksheet for this student
Found = False
For InxWsht = 1 To Worksheets.Count
If Worksheets(InxWsht).Name = StudentName Then
' Worksheet for this student found
Found = True
Exit For
End If
Next
If Not Found Then
' New student
' Create a new worksheet for this student
' Add new worksheet after all existing worlsheets
Worksheets.Add After:=Worksheets(Worksheets.Count)
' The new worksheet is now the active worksheet
ActiveSheet.Name = StudentName
' Note 1: I do not select anything because Select is a slow command.
' Note 2: Once I have merged range A1:L1, I write to cell A1. Cells
' B1 to L1 effectively no longer exist.
Range("A1:L1").Merge
With Range("A1")
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.Value = StudentName & "'s Spelling Words"
.RowHeight = 27.75
With .Font
.Bold = True
.Size = 14
End With
End With
With Worksheets("Dashboard")
' Find an empty column for this student and initialise it.
If .Cells(RowDshBrdFirstWordList - 1, ColDshBrdFirstName).Value = "" Then
' This is the first student
ColDshBrdCrnt = ColDshBrdFirstName
ElseIf .Cells(RowDshBrdFirstWordList - 1, ColDshBrdFirstName + 1).Value = "" Then
' This is the second student
ColDshBrdCrnt = ColDshBrdFirstName + 1
Else
' Find the first unused column
' .End(xlToRight) is the VBA equivalent of clicking Ctrl+RightArrow.
' Experiment with Ctrl+RightArrow to discover why I test the first and second
' columns before using .End(xlToRight).
ColDshBrdCrnt = .Cells(RowDshBrdFirstWordList - 1, _
ColDshBrdFirstName).End(xlToRight).Column + 1
End If
' Add name as title and fill column with Ns
.Cells(RowDshBrdFirstWordList - 1, ColDshBrdCrnt).Value = StudentName
.Range(.Cells(RowDshBrdFirstWordList, ColDshBrdCrnt), _
.Cells(RowDshBrdLast, ColDshBrdCrnt)).Value = "N"
End With
With Worksheets("Students")
' Record number of Ns in ToDo column
.Cells(RowStdLstCrnt, ColStdLstToDo).Value = _
RowDshBrdLast - RowDshBrdFirstWordList + 1
End With
End If ' Not Found
RowStdLstCrnt = RowStdLstCrnt + 1
Loop ' until student list exhaused
Worksheets("Dashboard").Activate
End Sub
Sub OutputWordLists()
Dim ColDshBrdCrnt As Long
Dim ColDshBrdLast As Long
Dim Found As Boolean
Dim InxRng As Long
Dim InxWsht As Long
Dim numToDo As Long
Dim Rng As Range
Dim RngCopy As Range
Dim RngDshBrdCrnt As Range
Dim RowDshBrdLast As Long
Dim RowStdLstCrnt As Long
Dim StudentName As String
' Find the last row and column of "Dashboard"
With Worksheets("Dashboard")
ColDshBrdLast = .Cells(RowDshBrdFirstWordList - 1, Columns.Count).End(xlToLeft).Column
Set Rng = .Cells.Find("*", .Range("A1"), xlFormulas, , xlByRows, xlPrevious)
If Rng Is Nothing Then
' No data found
Debug.Assert False
Exit Sub
Else
RowDshBrdLast = Rng.Row
End If
End With
Debug.Print "Last student column " & ColDshBrdLast
Debug.Print "Last word list on row " & RowDshBrdLast
' Loop for each student column
For ColDshBrdCrnt = ColDshBrdFirstName To ColDshBrdLast
' Get Student name and number of word list to do
With Worksheets("Dashboard")
StudentName = .Cells(RowDshBrdFirstWordList - 1, ColDshBrdCrnt).Value
Set Rng = .Range(.Cells(RowDshBrdFirstWordList, ColDshBrdCrnt), _
.Cells(RowDshBrdLast, ColDshBrdCrnt))
numToDo = Application.WorksheetFunction.CountIf(Rng, "N")
End With
Debug.Print StudentName & " has " & numToDo & " word lists to do"
' Locate row for this student in "Students"
With Worksheets("Students")
Set Rng = .Columns(1).Find(StudentName, .Range("A1"), xlFormulas, , xlByRows, xlPrevious)
If Rng Is Nothing Then
' Student not found
Debug.Assert False
Exit Sub
Else
RowStdLstCrnt = Rng.Row
End If
.Cells(RowStdLstCrnt, ColStdLstToDo).Value = numToDo
End With
With Worksheets("Dashboard")
' Locate all rows not done by this student
If .AutoFilterMode Then
' AutoFilter is on so turn off in case wrong filter selected
.Cells.AutoFilter
End If
.Cells.AutoFilter Field:=ColDshBrdCrnt, Criteria1:="N"
Set Rng = .AutoFilter.Range.SpecialCells(xlCellTypeVisible)
.Cells.AutoFilter ' Switch off
Debug.Print StudentName & " " & Rng.Address
Set Rng = Rng.EntireRow
Debug.Print StudentName & " " & Rng.Address
' Ensure a maximum of 10 rows have been selected for copying.
' Discard any header rows
Set RngCopy = Nothing
InxRng = 0
For Each RngDshBrdCrnt In Rng
If RngDshBrdCrnt.Row < RowDshBrdFirstWordList Then
' Ignore this header row
Else
If RngCopy Is Nothing Then
' First row
Set RngCopy = RngDshBrdCrnt
Else
' Subsequent row
Set RngCopy = Union(RngCopy, RngDshBrdCrnt)
End If
InxRng = InxRng + 1
If InxRng = 10 Then Exit For
End If
Next RngDshBrdCrnt
Debug.Print StudentName & " " & RngCopy.Address
' Reduce copy range to word lists. That is, exclude student columns
Set RngCopy = Intersect(RngCopy, .Range(.Columns(1), .Columns(ColDshBrdFirstName - 1)))
Debug.Print StudentName & " " & RngCopy.Address
End With
' Locate worksheet for this student
Found = False
For InxWsht = 1 To Worksheets.Count
If Worksheets(InxWsht).Name = StudentName Then
' Worksheet for this student found
Found = True
Exit For
End If
Next
If Not Found Then
' No worksheet for this student
Debug.Assert False
Exit Sub
End If
With Worksheets(InxWsht)
' Clear any existing contents except for title row
.Range(.Rows(2), .Rows(Rows.Count)).EntireRow.Delete
' Copy word lists across
RngCopy.Copy Destination:=.Range("A3")
End With
Next ColDshBrdCrnt
End Sub
If my answer to your question was helpful, you should accept the answer and move on. Questioners who come back for another bite are called vampireson Meta Stack Overflow. There are several reasons why you should accept and move on:
Accepting an answer is the site appropriate way of saying “thank you”.
The answerer may not know anything about the subject of the supplementary question which will be lost.
One of the objectives of Stack Overflow is to build a resource that programmers can mine at will for questions & answers relevant to their current need. The more topics covered in a single question, the less likely someone who is interested in one of those topics will find it. My answer may have helped you but how likely is it that: (1) someone else has a similar need and (2) if they did that they would find my answer under the title “VBA Spelling test”.
I probably should have voted to close your question as too broad. However, I like to get those new to programming started and to prove that their requirement can be met with VBA macros. I learnt my first programming language at university in 1965. I have maintained that skill (albeit with new languages) because at home and at work there have been many tasks that are easy to perform with the aid of a program but hard without. In my opinion you are absolutely right when you say: “as an early-career teacher, I can see a huge range of uses for it.”
I am not a great fan of VBA. Excel has some extraordinarily useful functions but the language is limited. I learnt it because it was the only way of creating programs at work.
I am not sure I would be helping you develop if I wrote another macro for you. I certainly would not be helping Stack Overflow achieve its objective by linking another macro to this question.
You give an overview of your current objectives. I have not studied Spelling.xlsm in enough detail to know what would be the next step. I do not have the time to match the current state of your macros against your objective so as to identify the next step. You need to do that.
Having identified the next step, do you know enough to code it? If not, sum up the next step in a few words. With Stack Overflow, search for “[excel-vba] xxxxxxx” which means search for questions with tag excel-vba and topic xxxxxxx. Look through the results for relevant code. If necessary, revise xxxxxxx; it might take a few goes to home in on the right question. Although I think Stack Overflow is the best, there are other technique forums. Try goggling for “xxxxxxx” or “Excel VBA: xxxxxxx”.
If you pick up some ideas, write the smallest macro you can that will prove you have understood how to perform that step. If you are unable to get that macro working, post it here with a statement of what it does and what you want it to do. Questions like that will small blocks of code and a clear statement of what is going wrong are often answered in minutes. I might be the person who answers that question although probably not because I normally only look at questions unanswered after 24 hours.