Im very new to visual basic and macros. what i have been trying to do is create a macro that will look through the whole document and check to see if any of the font is red;if it is red then i want to change the red font to a white font.
I know my code is wrong but can anyone tell me what i am doing wrong?
Sub red()
If Font.Color =wdColorRed Then
Font.Color = -603914241
End Sub
You can use the following which is fairly quick (no looping required for each sheet).
Sub Macro1()
Application.ScreenUpdating = False 'disable the screen from updating, i.e, avoid excel redrawing the screen after each color change we make
Application.FindFormat.Font.Color = 255
Application.ReplaceFormat.Font.Color = 16777215
Cells.Select
Selection.Replace What:="", Replacement:="", MatchCase:=False, SearchFormat:=True, ReplaceFormat:=True
Application.ScreenUpdating = True 'enable screen updating
End Sub
Font colors can be a little tricky. So to find out what color you want, select a cell and change the color to a color you need to know the number for. Then go to your developer screen and View -> Immediate Window (or hit Ctrl+G). Then in the Immediate window (should now be at the bottom of your screen, with the cell that has you color you want to know still selected, type
? Selection.Font.Color
and this will give you the color you are interested in. Then put those numbers in Application.Find/ReplaceFormat.Font.Color above.
This will work for the sheet selected, you can simply throw this in a loop and iterate over all the sheets in a workbook to change them all.
Is it what you are looking for ?
Copied from here #Todd Main Answer.
Sub ChangeColorWithReplace()
Selection.Find.ClearFormatting
Selection.Find.Font.Color = wdColorRed
Selection.Find.Replacement.ClearFormatting
Selection.Find.Replacement.Font.Color = -603914241
With Selection.Find
.Text = ""
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchKashida = False
.MatchDiacritics = False
.MatchAlefHamza = False
.MatchControl = False
.MatchByte = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
End Sub
Related
I want to delete the red highlighting color from the MS Word document.
Explanation:
I made a module in MS Word documents that search/find any text highlighting with red color - a text marked with red from the tool shown in the image below. The following code is either working fine or make the MS Word stop responding. I'm not sure why it gets crashing, but I guess due to the loop that I am using. I wish there is something like: .Replacement.HighlightColorIndex = wdred ; and then .Execute Replace:=wdReplaceAll ; instead of the loop.
The VBA code that I wrote:
Sub RemoveSpecificHighlightingColor()
'
' Remove Specific Highlighting Color Macro
' This Macro go through the document and search for any Red color highlighting word and remove it
' colors code: https://learn.microsoft.com/en-us/office/vba/api/word.wdcolorindex
'
Selection.GoTo wdGoToPage, wdGoToAbsolute, 1 'Start at the top of the document
Selection.Find.ClearFormatting
Selection.Find.Highlight = True
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = ""
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop 'stop at the end of the document
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
Do While (.Execute(Forward:=True) = True) = True
DoEvents 'keeps Word responsive
If Selection.Range.HighlightColorIndex = wdRed Then
Selection.Range.Delete
End If
Loop
MsgBox "Done!" ' just for testing
End With
End Sub
Some explanation about the code:
I noticed if I select at the middle of the document then run the code, the code start from the mouse selection not from the top. This is why I mentioned the first statement.
Some of the code I got from the record marco feature and from help online. The record marco detect all highlighting color not specific color.
I used Selection.Find so I selected .Wrap = wdFindStop
There is no difference if I keep or remove Format, MatchCase, MatchWholeWord, MatchWildcards, MatchSoundsLike, and MatchAllWordForms.
The main issue is the While loop or any loop that I am using. The one shown in the code check for all highlighting colors and if the color is red, then remove it, otherwise check for another.
Any help is appreciated, thanks!
The big problem with your code is that you are using the Selection object. When you select things in your code the screen has to be redrawn with each change of selection. As Selection.Find selects every match it finds that is a lot of redrawing.
In this instance you can avoid using Selection by using a Range object instead (ActiveDocument.Content is a range). When you use .Find with a range the range is redefined each time a match is found, enabling you to change the properties of that range.
Sub RemoveSpecificHighlightingColor()
Application.ScreenUpdating = False
With ActiveDocument.Content
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Highlight = True
.Text = ""
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop 'stop at the end of the document
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Do While .Find.Execute = True
If .HighlightColorIndex = wdRed Then .Delete
Loop
End With
Application.ScreenUpdating = True
End Sub
For example:
Sub Demo()
Application.ScreenUpdating = False
With ActiveDocument.Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = ""
.Replacement.Text = ""
.Format = True
.Forward = True
.Highlight = True
.Wrap = wdFindStop
End With
Do While .Find.Execute
If .HighlightColorIndex = wdRed Then .Delete
'The next If ... End If block is needed if the highlighted content could be in a table
If .Information(wdWithInTable) = True Then
If .End = .Cells(1).Range.End - 1 Then
.End = .Cells(1).Range.End
.Collapse wdCollapseEnd
If .Information(wdAtEndOfRowMarker) = True Then
.End = .End + 1
End If
End If
End If
'The next line is needed if the highlighted content could include the final paragraph break
If .End = ActiveDocument.Range.End Then Exit Do
.Collapse wdCollapseEnd
Loop
End With
Application.ScreenUpdating = True
End Sub
Do note that there's a bug in Word's Find which means it won't find anything if the document consists of a single highlighted paragraph. Additionally, I haven't included code to test whether a found range spans some text as well as part of a field or spans two or more highlight colours. Consequently, neither condition will be processed.
I tried to trace the issue. What I noticed is, in some documents only (mixed of .doc and .docx file type), once I run the code, it goes through the document pages and finds and deletes the red highlighting color, that once all are replaced, the MS Word stuck. Once the MS Word got stuck, the cursor is changing rapidly, as if the screen has to be redrawn, and after a few seconds the program stops responding, and even if I wait for a while it will be stuck until I force to close the MS Word. This happened with or without red highlighting color in the document.
Explanation of the code:
The code runs each page alone by making the code start from the first page and count the number of pages. Then go through each page and select the text.
Apply the filtering code and deleting for the specific selection only, then check for a new page.
I treated the pause/stuck as a bouncing button without a pull-up or pull-down resistor i.e., once the physical button is pressed it fluctuate before it reaches a steady state.
Iteration...
The final code that I used, and It's now working for all documents is shown below:
Sub RemoveSpecificHighlightingColor()
'
' Remove Specific Highlighting Color Macro
' This Macro go through the document and search for any Red color highlighting word and remove it
' colors code: https://learn.microsoft.com/en-us/office/vba/api/word.wdcolorindex
'
Dim NumberOfAllPages As Integer
' Dim LastPageNumber As Integer
Dim PageNumber As Integer
Dim TempCounter As Integer
Dim TemoEnd As Long
Selection.Find.ClearFormatting
PageNumber = 1 'Starting page
NumberOfAllPages = ActiveDocument.ActiveWindow.Panes(1).Pages.Count
' LastPageNumber = 3 'Last page to reach - for testing
Selection.GoTo wdGoToPage, wdGoToAbsolute, PageNumber 'GoTo Page PageNumber
' Debug.Print "Start"
While PageNumber - 1 < NumberOfAllPages 'LastPageNumber
DoEvents 'keeps document responsive
Selection.GoTo wdGoToPage, wdGoToAbsolute, PageNumber 'GoTo Page PageNumber
Selection.Bookmarks("\Page").Select 'Select all the text in the page
With Selection.Find
.Highlight = True
.Text = ""
.Replacement.Text = ""
.Forward = True
Do While (.Execute(Forward:=True) = True) = True
DoEvents 'keeps document responsive
If Selection.Range.HighlightColorIndex = wdRed Then Selection.Range.Delete
' If the process is stuck at the same location for while then (50 times) it mean the page is full check from Red Highlighting Color
If ActiveWindow.Selection.End = TemoEnd Then
TempCounter = TempCounter + 1
End If
If TempCounter > 50 Then Exit Do
' Debug.Print ActiveDocument.Range.End
' Debug.Print ActiveWindow.Selection.End
TemoEnd = ActiveWindow.Selection.End
Loop
End With
TempCounter = 0 ' reset counter
' Debug.Print PageNumber
PageNumber = PageNumber + 1
Wend
End Sub
I can't tell you where your error is, but here's a working code
Sub UNHIGHCOLOR()
'HOW MANY HIGHLIGHT REGIONS ARE - store to AAAM
Selection.HomeKey wdStory
'HIG_COUNT Macro
'CTRL-FN-SHIFT TO BREAK
START:
'Selection.HomeKey wdStory
Selection.Find.ClearFormatting
Selection.Find.Highlight = True
With Selection.Find
.Text = ""
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Execute
If .Found Then
'MsgBox "found"
If Selection.Range.HighlightColorIndex = wdRed Then
'MsgBox "RED"
'Selection.Range.HighlightColorIndex = 0
End If
AAAM = AAAM + 1
GoTo START
Else
'MsgBox "not found"
'MsgBox AAAM & " HIGH REGIONS"
End If
End With
Selection.HomeKey wdStory
'*********************************************************
'FOR AAAM REGIONS CHANGE HIGHLIGHT RED COLORS TO NO COLOR
For X = 1 To AAAM + 1
'UNHIGHCOLOR_RED_NEXT
Selection.Find.ClearFormatting
Selection.Find.Highlight = True
With Selection.Find
.Text = ""
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Execute
End With
If Selection.Range.HighlightColorIndex = wdRed Then
'MsgBox "RED"
Selection.Range.HighlightColorIndex = 0 'NO COLOR
End If
Selection.Collapse (wdCollapseEnd) 'TO FIND NEXT
Next
End Sub
I have a question about a problem i need do solve.
I have a word doc, on which i want to run a search and replace query.
But i dont want to change the actual text, i want to put the changed text
in the clipboard and leave the actual one unchanged.
Sub SearchAndReplace()
' marks all bold words,italic words, underlined
Selection.Find.ClearFormatting
Selection.Find.Font.Bold = True
Selection.Find.Font.Italic = True
Selection.Find.Font.Underline = wdUnderlineSingle
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = ""
.Replacement.Text = "[test]^&[/test]"
.Forward = True
.Wrap = wdFindContinue
.Format = True
.MatchCase = False
.MatchWholeWord = True
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = True
End With
Selection.Find.Execute Replace:=wdReplaceAll
End Sub
Cautious:
I guess there are better ways to achieve what you want to do as this is not proper coding. (Also as the clipboard only has a limit of 24 items), but for the sake of making your code works, here is my answer:
To copy the text in the clipboard instead of replacing it, you can just use the .copy method.
If you replace your line:
Selection.Find.Execute Replace:=wdReplaceAll
by
Dim iCount As Long
Selection.Find.Execute
Selection.Copy
Do While Selection.Find.Found = True And iCount < 1000
iCount = iCount + 1
Selection.Find.Execute
Selection.Copy
Loop
it should work.
The code is simply copying the item found after each search.
Selection.Find.Execute searches the next itteration of the search every time it appears in the code.
Once there are no search found anymore (or there are too many searches), the loop will stop.
I have a macro that jumps to the next occurrence of red text in a document.
It works fine until it gets to a paragraph that is all red (including the paragraph mark). It then won't move forward in the document until I move the cursor forward and try again.
I've also noticed that when the cursor is within the paragraph, if I run the macro, only the text from the cursor to the end of the paragraph is highlighted.
I suspect I need to use some form of 'collapse'? Can anyone advise?
Here's the code:
Sub Find_Red_Text()
With ActiveDocument.ActiveWindow
.ActivePane.View.SeekView = wdSeekMainDocument
Selection.Find.ClearFormatting
Selection.Find.Font.Color = wdColorRed
With Selection.Find
.Text = ""
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute
End With
End Sub
I'm trying to work on my first (and hopefully the last) Macro on Word and I have come to a dead-end. As I am working a lot between Word and Word Online the formatting tends to change so I need to create a Macro that will save me the trouble of re-adjusting it manually.
My problem is that I need to have different spacing on my body text based on the font used (for Arial to have spacing before 6 and for Courier New that we use for code spacing before 0). I have tried to create the code using the Macro Recorder and the Replace function but the recorder gives me a generic code that doesn't specify the font I need (although I choose it) so when I run both I end up with the Arial formatting on both. Here is the code I get for the Courier New:
Sub FormatBodyCode()
Application.ScreenUpdating = False
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find.Replacement.ParagraphFormat
.SpaceBefore = 0
.SpaceBeforeAuto = False
.SpaceAfter = 0
.SpaceAfterAuto = False
.LineSpacingRule = wdLineSpaceMultiple
.LineSpacing = LinesToPoints(1.15)
.Alignment = wdAlignParagraphLeft
.OutlineLevel = wdOutlineLevelBodyText
.LineUnitBefore = 0
.LineUnitAfter = 0
End With
With Selection.Find
.Text = ""
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
Application.ScreenUpdating = True
End Sub
How can I specify the font to make it work?
One quick code change should restrict the search for a single font:
...
With Selection.Find
...
.Format = True
.Font.Name = "Courier New" ' <== Add this - Or whatever font you want
...
The easiest way to do multiple fonts is to copy the whole function to another function with a different name and change the font name and spacing in the other function.
I've made an excel visual basic script that takes data from an excel sheet, and produces a paragraph in a word sheet for each row. The default language for the document is Hebrew, with text aligned right and direction right to left.
For one (the last) line in the paragraph, I want to set the language to English, the direction left to right, and the alignment right. Then, for the first line in the next paragraph change back to Hebrew, direction right to left and alignment right.
When recording a macro in word when being on the last line of a paragraph, pressing home, shift end, clicking the icons on the toolbar to change language, direction and alignment as wanted, I get:
Sub test()
Selection.HomeKey Unit:=wdLine
Selection.EndKey Unit:=wdLine, Extend:=wdExtend
Application.Keyboard (2057)
Selection.LtrPara
Selection.ParagraphFormat.Alignment = wdAlignParagraphRight
End Sub
One thing that surprised me is that changing the language is recorded as if I was using the keyboard, instead of being a property of the object, just like direction and alignment.
How do I translate this to excel visual basic? The line in question is currently added by using:
With f
.Content.InsertAfter Format(a, "standard") & " x " & Format(b, "#,##0.000") & " x " & Format(c, "#,##0.000") & " / " & Format(d, "#,##0.000") & " = " & Format(e, "standard")
.Content.InsertParagraphAfter
End With
Thanks,
Ernst
Okay, I've got a workaround, this is only a partial answer. This is not a solution in Excel visual basic, but one in Word:
Search for all occurences of ^13[!^13]#x*^13 and then do the language, alignment and direction change.
When recording it as a macro in word, I get the following:
Sub Macro1()
Selection.Find.ClearFormatting
With Selection.Find
.Text = "^13[!^13]#x*^13"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchKashida = False
.MatchDiacritics = False
.MatchAlefHamza = False
.MatchControl = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = True
End With
Selection.LtrPara
Selection.ParagraphFormat.Alignment = wdAlignParagraphRight
Selection.Find.ClearFormatting
With Selection.Find
.Text = "^13[!^13]#x*^13"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchKashida = False
.MatchDiacritics = False
.MatchAlefHamza = False
.MatchControl = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = True
End With
End Sub
But when running this on a freshly generated Word document, this does not do what it's supposed to do. Any ideas for a workaround on that? Btw, can I add and run a word macro to a document generated by excel vb using excel vb?