Closed. This question needs debugging details. It is not currently accepting answers.
Edit the question to include desired behavior, a specific problem or error, and the shortest code necessary to reproduce the problem. This will help others answer the question.
Closed 4 days ago.
Improve this question
Ideally, I need code that counts the number of characters (i.e. 500) then finds the end of the sentence and adds a paragraph break.
Use case: I have transcriptions that are spit out without any paragraph breaks. I need code that breaks it up into paragraphs to make it more readable.
Got anything relatively simple for this? Thanks.
I don't know enough VBA to write the code. I've been using AI to give me snippets and it gives me the worst answers. The only thing I've been able to accomplish is deleting all the text and replacing it with the same line over and over again. Clearly not what I wanted to accomplish.
UPDATE: I ended up using this code. Seems to work pretty good. Need to play with it a bit:
Sub TextSplitter()
Dim Rng As Range
Application.ScreenUpdating = False
With ActiveDocument
Set Rng = .Range(0, 0)
Do
With Rng
On Error GoTo ErrExit
.MoveEndUntil cset:=vbCr, Count:=wdForward
If Len(.text) > 500 Then
.End = .Start + 500
.End = .Start + InStrRev(Rng.text, ".") + 1
If .Characters.Last.text <> vbCr Then
.Characters.Last.Delete
.InsertAfter vbCr
End If
End If
DoEvents
.Start = .Paragraphs.Last.Next.Range.Start
End With
Loop Until Rng Is Nothing
ErrExit:
End With
Set Rng = Nothing
Application.ScreenUpdating = True
End Sub
Related
Iam just starting with using the word macros. I have a problem to identify all cross references and hyperlinks in the word document. Iam using a macro to solve this problem
The macro i have written is.
For Each fld In ActiveDocument.Fields
If fld.Type = wdFieldRef Or fld.Type = wdFieldHyperlink Then
fld.Select
For Each ch In Selection.Characters
ch.HighlightColorIndex = wdYellow
Next
End If
Next
This is the macro I have written, it is working as expected but it is too slow that i cannot use it.
There must be an efficient way to solve this problem. If yes please let me know-how.Any reference to sites so that I can refer would also be ok.
Thanks
Disable screen updating and avoid selecting anything wherever possible. For example:
Sub Demo()
Application.ScreenUpdating = False
Dim Fld As Field
For Each Fld In ActiveDocument.Fields
With Fld
Select Case .Type
Case wdFieldRef, wdFieldPageRef, wdFieldHyperlink
.Result.HighlightColorIndex = wdYellow
End Select
End With
Next
Application.ScreenUpdating = True
End Sub
I have a simple loop (below) that looks for sentences over 30 words long. If found, it adds a comment box to the selected sentence. It worked fine in testing. Then I added some test endnote citations...and it fails to find the long sentences.
However, it only fails when there is no space between the period and the citation superscript. If I add a space, it finds it and works perfectly. The problem is, there is not suposed to be a space between the period and the citation, per the style guide I have to follow at work.
This related Stack thread discusses the need for a space after a period to delineate the end of a sentence. I am assuming the space must be directly after the period, because I have spaces in my citations like this 1, 2, 3
Question
How can I find instances of period+superscript (with no space like this --> This is a sentence.1, 2, 3) and add a space? Ideally I would like this to happen within the below loop so I can remove the space after the comment gets added.
Sub Comment_on_Long_Sentences ()
Dim iWords as Integer
iWords = 0
For Each MySent in ActiveDocument.Sentences
If MySent.Words.Count > iWords Then
MySent.Select
'find and delete space
ActiveDocument.Comments.Add Range:= Selection.Range, Text:= "Long Sentence: " & iWords & " words"
'put the space back
End if
Next MySent
End Sub
There appears to be issues in VBA when trying to access Sentences that end with a superscript character. Your code also has problems with non-declared variables, so I have no idea how it ever worked for you in the first place.
Try this following VBA routine, it works in my environment. Also notice the special handling that I found is required for 1st sentences in paragraphs and when that sentence ends with a superscript character.
Sub Comment_on_Long_Sentences()
Dim doc As word.Document, rng As word.Range, para As word.Paragraph
Dim i As Long
Set doc = ActiveDocument
For Each para In doc.Paragraphs
Debug.Print para.Range.Sentences.Count
For i = 1 To para.Range.Sentences.Count
Set rng = para.Range.Sentences(i)
If i = 1 And rng.Characters.First.Font.Superscript = True Then
rng.MoveStart word.WdUnits.wdSentence, Count:=-1
End If
If rng.words.Count > 30 Then
doc.Comments.Add Range:=rng, Text:="Long Sentence: " & rng.words.Count & " words"
End If
Next
Next
End Sub
Here is an alternative solution. Note the option explicit at the start. Its good VBA practice to put this at the top of every module.
The problem you have is very common. Find something then rather than do a replace, do some other non replace related stuff. The subs to add and remove spaces before citations implement this pattern and are well worth studying.
If you don't understand anything then in the VBA IDE just put your cursor on the relevant keyword and press F1. This will bring up the relevant MS help page.
Option explicit
Sub Comment_on_Long_Sentences()
Dim iWords As Integer
Dim my_sentence As Variant
iWords = 30
AddSpaceBeforeCitations
For Each my_sentence In ActiveDocument.Sentences
If my_sentence.Words.Count > iWords Then
my_sentence.Comments.Add Range:=my_sentence, Text:="Long Sentence: " & iWords & " words"
End If
Next my_sentence
RemoveSpaceBeforeCitations
End Sub
Sub AddSpaceBeforeCitations()
With ActiveDocument.Content
With .Find
.ClearFormatting
.Format = True
.Text = ""
.Wrap = wdFindStop
.Font.Superscript = True
.Execute
End With
Do While .Find.Found
With .Previous(unit:=wdCharacter, Count:=1).characters
If .Last.Text = "." Then
.Last.Text = ". "
End If
End With
.Collapse direction:=wdCollapseEnd
.Move unit:=wdCharacter, Count:=1
.Find.Execute
Loop
End With
End Sub
Sub RemoveSpaceBeforeCitations()
With ActiveDocument.Content
With .Find
.ClearFormatting
.Format = True
.Text = ""
.Wrap = wdFindStop
.Font.Superscript = True
.Execute
End With
Do While .Find.Found
With .Previous(unit:=wdCharacter, Count:=2).characters
If (.Last.Text = ".") Then
.Last.Next(unit:=wdCharacter, Count:=1).characters.Last.Text = vbNullString
End If
End With
.Collapse direction:=wdCollapseEnd
.Move unit:=wdCharacter, Count:=1
.Find.Execute
Loop
End With
End Sub
No matter what approach you take, any code that relies on the VBA .Sentence property or .Word property is going to produce unreliable results. That's because .Sentence has no idea what a grammatical sentence and .Word has no idea what a grammatical word is. For example, consider the following:
Mr. Smith spent $1,234.56 at Dr. John's Grocery Store, to buy 10.25kg of potatoes, 10kg of avocados, and 15.1kg of Mrs. Green's Mt. Pleasant macadamia nuts.
For you and me, that would count as one, 26-word sentence; for VBA it counts as 5 sentences containing 45 words overall. For an accurate word count, use .ComputeStatistics(wdStatisticWords). Sadly there is no .ComputeStatistics(wdStatisticSentences) equivalent for sentences.
I am using the following VBA macro to add page numbers after all bookmark hyperlinks in my document:
Sub InsertPageRefs()
Application.ScreenUpdating = False
Dim hLnk As Hyperlink, Rng As Range
For Each hLnk In ActiveDocument.Hyperlinks
With hLnk
If InStr(.SubAddress, "_Toc") = 0 And .Address = "" Then
Set Rng = .Range
With Rng
.Collapse Direction:=wdCollapseEnd
.InsertAfter Text:=" (See page #)"
.Font.Underline = wdUnderlineNone
End With
ActiveDocument.Fields.Add Range:=Rng.Characters(InStr(Rng, "#")), Text:="PAGEREF " & .SubAddress
End If
End With
Next
Set Rng = Nothing
Application.ScreenUpdating = True
Application.ScreenRefresh
MsgBox ActiveDocument.Hyperlinks.Count & " page numbers have been added.", vbOKOnly
End Sub
However, it's having undesirable results.
The blue color of the hyperlinks is partially spilling over into the added text.
It's creating a bunch of crazy span tags when I save the resulting file to HTML. I don't want this because I am going to convert the HTML to .mobi for Kindle and all the span tags are going to create chaos in my .mobi.
How do I strip out all the formatting and insert the page numbers in the "Normal" word style?
I suspect the real answer for this would be to use a good e-book editor that will keep track of this for you.
That said, the problem is likely that you are working on the Hyperlink's range, so all you should have to do is duplicate it. This allows the formatting of your range separate itself from whatever formatting is attached to the hyperlink. The other benefit of using a duplicate of a Hyperlink's range is that you can operate on the text of the range directly without destroying the link, which is also an easy way to preserve the target formatting:
Sub InsertPageRefs()
Dim hLnk As Hyperlink
Dim Rng As Range
For Each hLnk In ActiveDocument.Hyperlinks
If InStr(hLnk.SubAddress, "_Toc") = 0 And hLnk.Address = vbNullString Then
Set Rng = hLnk.Range.Duplicate
Rng.Start = Rng.End
Rng.Text = " (See page #)"
Rng.Font.Underline = wdUnderlineNone
ActiveDocument.Fields.Add Range:=Rng.Characters(InStr(Rng, "#")), _
Text:="PAGEREF " & hLnk.SubAddress
End If
Next
MsgBox ActiveDocument.Hyperlinks.Count & " page numbers have been added.", vbOKOnly
End Sub
Note that I pulled out the With blocks to make this more readable. Nested Withs make it a lot more difficult to tell at a glance what object you're operating on.
Closed. This question does not meet Stack Overflow guidelines. It is not currently accepting answers.
This question appears to be off-topic because it lacks sufficient information to diagnose the problem. Describe your problem in more detail or include a minimal example in the question itself.
Closed 8 years ago.
Improve this question
Need to sum by font color some columns. I only have the code above that of course sums everything.
Sub sum()
With Sheets("sheet4").Range("a1").CurrentRegion
If .Cells(.Rows.Count, 1).Value <> "Total" Then
With .Offset(.Rows.Count).Resize(1)
.Formula = "=sum(r2c:r[-1]c)"
.Columns(1).Value = "Total"
End With
End If
End With
End Sub
If you need to iterate through a range and do something by font color, you could do something like the following. To use it, you will need to pass it the range you want to look through, and a range which has the font color you want to look for in it. This is easier than having to enter the full color number for the shade of green you want to look for - just copy a green fonted cell to another sheet, and pass that in as the parameter.
Sub DoSomethingByFontColor(ByRef xlRange As Excel.Range, ByRef checkColorrange As Excel.Range)
Dim xlcell As Excel.Range, i as long
For Each xlcell In xlRange
If xlcell.Font.Color = checkColorrange.Font.Color Then
'do something
i = i + 1
End If
Next xlcell
Debug.Print "There were " & i & "incidences of font color " & _
checkColorrange.Font.Color & " in the check range."
End Sub
Sub test()
DoSomethingByFontColor Sheet1.Range("C1:C5"), Sheet1.Range("a1")
End Sub
I have a long list of terms. Over 90% are misspellings. Most of which are two words that have no space in the middle. I noticed that MS Word, Excel, Office, etc. is pretty good at suggesting the correct spelling. When I run the spellchecker, I don't have time to confirm each and every suggested correction. Having some errors are OK.
How can I automate spellcheck, or rather "spellcorrect" without prompting? I don't mind using other tools besides Microsoft, but it's spellchecker seems pretty good. I tried some VBA code to use with Excel, but I can't find anything that will programmatically show me the main suggestion so that I can replace the misspelled term.
Sub spellcheck()
With Application.SpellingOptions
.SuggestMainOnly = True
.IgnoreCaps = True
.
End With
Cells.CheckSpelling
End Sub
Any help is appreciated. And please I understand the danger of auto-correct. The impact of wrongful corrections is minimal.
Thanks,
Steve
A third party spell checker, such as aspell might give you the most speed & flexibility. But apparently, you can control the spell checker of Access, so that might be a possibility.
Given your special case of errors being due to lack of space between two words though, you may be able to get by with Excel's spell checker:
Sub test()
Dim str, correction As String
Dim i As Long, n As Long
With Application
For Each str In Array("pancake", "sausagebiscuit", "oatmeal", "largecoffee")
correction = str ' by default leave alone
If .CheckSpelling(str) Then
' already a word
Else
n = Len(str)
For i = 1 To n
If .CheckSpelling(Left$(str, i)) And .CheckSpelling(Right$(str, n - i)) Then
correction = Left$(str, i) & " " & Right$(str, n - i)
End If
Next
End If
Debug.Print str & " -> " & correction
Next
End With
End Sub
Output:
pancake -> pancake
sausagebiscuit -> sausage biscuit
oatmeal -> oatmeal
largecoffee -> large coffee
Mmmm, breakfast....
Assuming that you have a list of misspelled words in column A (starting in row 1) and their corrections in column B, you can use this macro to add them the Office's Autocorrect library. This way, Excel will replace the word with its correction right after the word is entered.
Sub subAddAutoCorrects()
Dim rng As Range
Set rng = Sheets("Sheet1").Range("A1")
While rng ""
Application.AutoCorrect.AddReplacement What:=rng.Value, Replacement:=rng.Offset(, 1).Value
Set rng = rng.Offset(1)
Wend
End Sub
It's been more than a year, but maybe you still need the solution to the problem.
Try this (in ms word):
Sub use_suggestion()
Dim rng As Range
Dim i As Long
For i = 1 To ActiveDocument.Range.SpellingErrors.Count
Set rng = ActiveDocument.Range.SpellingErrors(i)
If rng.GetSpellingSuggestions.Count <> 0 Then
rng = rng.GetSpellingSuggestions.Item(1).Name & "ZXQ"
End If
Next i
Selection.HomeKey Unit:=wdStory
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = "ZXQ"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
End With
Selection.Find.Execute Replace:=wdReplaceAll
End Sub
Note: the misspelled words that have no suggestion will not change.