#1
|
|||
|
|||
VBA help remove duplicates of blanks
I have today been given quite a few documents to house style and the first thing I need to do is to remove the coloured coding within the document. I have put together a small macro which deals with most of the tasks in one go, however, I can't work out how to remove duplicates of [●] to just one [●].
I then put these blank spaces into a text form field by using a find and replace ^c as I've never worked out how to add this step into a macro. If anyone can help with the duplication issue that would be great. I've added a very small reduced size document as the ones I'm working on are 100+ pages. coded test document.docx coding 1.png coding 2.png Code:
Sub DeleteCoding() Application.ScreenUpdating = False Dim Rng As Range With Selection.Range Set Rng = Selection.Range With Rng.Find .ClearFormatting .Replacement.ClearFormatting .Forward = True .Wrap = wdFindContinue .Format = False .MatchWildcards = True .text = "[\{]{1,}[!\}]@[\}]{1,}" 'find text within curly braces and replace with square bracket blank .Replacement.text = "[" & ChrW(9679) & "]" .Execute Replace:=wdReplaceAll .MatchWildcards = False .text = "<" 'remove all instances of less than symbol .Replacement.text = "" .Execute Replace:=wdReplaceAll .text = ">" 'remove all instances of greater than sumbol .Replacement.text = "" .Execute Replace:=wdReplaceAll End With With Rng.Find .Format = False .Font.Superscript = True 'remove superscript wording .text = "" .Replacement.text = "" .Execute Replace:=wdReplaceAll End With Application.ScreenUpdating = True End With End Sub |
#2
|
||||
|
||||
This modification appears to get all of them apart from the ones separated by a space. Do you want those as well?
Code:
Sub DeleteCoding() Dim Rng As Range 'Application.ScreenUpdating = False Set Rng = Selection.Range With Rng.Find .ClearFormatting .Replacement.ClearFormatting .Forward = True .Wrap = wdFindContinue .Format = False .MatchWildcards = True .Text = "[\{]{1,}[!\}]@[\}]{1,}" 'find text within curly braces and replace with square bracket blank .Replacement.Text = "[" & ChrW(9679) & "]" .Execute Replace:=wdReplaceAll .Text = "[\[" & ChrW(9679) & "\]]{4,}" .Execute Replace:=wdReplaceAll .MatchWildcards = False .Text = "<" 'remove all instances of less than symbol .Replacement.Text = "" .Execute Replace:=wdReplaceAll .Text = ">" 'remove all instances of greater than sumbol .Replacement.Text = "" .Execute Replace:=wdReplaceAll .Format = False .Font.Superscript = True 'remove superscript wording .Text = "" .Replacement.Text = "" .Execute Replace:=wdReplaceAll End With 'Application.ScreenUpdating = True End Sub
__________________
Andrew Lockton Chrysalis Design, Melbourne Australia |
#3
|
|||
|
|||
VBA help remove duplicates of blanks
Hi Andrew, thank you for replying - I added your extra bit of code and I think it has removed a few of the duplicates but many still remain - with regard to your query re separated by spaces, yes that would be great if those could be included also.
Code:
.text = "[\[" & ChrW(9679) & "\]]{4,}" .Execute Replace:=wdReplaceAll Capture 2.JPG |
#4
|
|||
|
|||
VBA help remove duplicates of blanks
Hi Andrew, I wondered if you had had a chance to look at the code, no worries if not, I have been doing a lot of research online but there isn't much out there relating to duplicates in Word, lots for excel but not a lot for Word. thanks again.
|
#5
|
||||
|
||||
Try this version
Code:
Sub DeleteCoding() Dim Rng As Range 'Application.ScreenUpdating = False Set Rng = Selection.Range With Rng.Find .ClearFormatting .Replacement.ClearFormatting .Forward = True .Wrap = wdFindContinue .Format = False .MatchWildcards = False .Text = "<" 'remove all instances of less than symbol .Replacement.Text = "" .Execute Replace:=wdReplaceAll .Text = ">" 'remove all instances of greater than sumbol .Replacement.Text = "" .Execute Replace:=wdReplaceAll .Format = False .Font.Superscript = True 'remove superscript wording .Text = "" .Replacement.Text = "" .Execute Replace:=wdReplaceAll .MatchWildcards = True .ClearFormatting .Text = "[\{]{1,}[!\}]@[\}]{1,}" 'find text within curly braces and replace with square bracket blank .Replacement.Text = "[" & ChrW(9679) & "]" .Execute Replace:=wdReplaceAll .MatchWildcards = False .Text = "]^w[" 'remove spaces between ][ .Replacement.Text = "][" .Execute Replace:=wdReplaceAll .MatchWildcards = True .Text = "[\[" & ChrW(9679) & "\]]{4,}" .Replacement.Text = "[" & ChrW(9679) & "]" .Execute Replace:=wdReplaceAll End With 'Application.ScreenUpdating = True End Sub
__________________
Andrew Lockton Chrysalis Design, Melbourne Australia |
#6
|
|||
|
|||
VBA help remove duplicates of blanks
Andrew you are a genius, thank you so much, I worked on this all weekend and didn't get anywhere close, I really appreciate your help, best wishes - Shelley
|
#7
|
|||
|
|||
VBA help remove duplicates of blanks updated
Hi Andrew, I've tidied up the code a little bit with regard to searching and deleting the less than and greater than symbols which is working great. I'm trying to work out how to include the superscript text within those symbols to be deleted at the same. It does appear however that the less than symbol followed by blue superscript text doesn't always have a closing greater than symbol - I'm probably over thinking it too much and should leave it alone but I was just curious how I would include searching for text within two Chr values.
Code:
.text = "[" & Chr(60) & Chr(62) & "]" .Replacement.text = "" .Execute Replace:=wdReplaceAll |
Thread Tools | |
Display Modes | |
|
Similar Threads | ||||
Thread | Thread Starter | Forum | Replies | Last Post |
find/remove duplicates | hephalumph | Word | 9 | 02-06-2022 07:23 PM |
look for VBA to remove Duplicates from Subfolders | nf24eg | Outlook | 0 | 08-12-2021 05:03 AM |
Macro to keep first instance and remove duplicates in certain column | zhead | Excel | 2 | 03-18-2015 10:16 AM |
Counting Blanks in 1 Column and Non-Blanks in Another | dogwood705 | Excel | 4 | 02-07-2015 08:45 AM |
Macro to remove duplicates in Refrences list | HowardC | Word VBA | 0 | 05-20-2010 09:57 AM |