WORD VBA to create block text

I have reached an impasse with my limited VBA skills and ask if anybody can figure out this task. :rolleyes:

Simply stated, I need to remove all formatting from copied and pasted text into a new document, and to have all text be in one big block of text . If there are text boxes that can be deleted and text copied into the body of the text that would be fantastic -- I also need paragraph spacing to be removed and appended to the end of the previous line of text. I have attached photos of what I need below. It isn't too pertinent that the text be the same format, but if possible to make it 12pt and non-bold italics or underlined that would be fantastic.

I can't seem to get it all to work and I find myself just doing it the hard way anyways. :eek: Any help is appreciated, and thank you in advance. :thumb:

What it looks like upon copy paste:
Attachment 153709

What I need it to look like after running Macro:
Attachment 153711

Hi,

Your pictures does not really tell me much, they are not even from the same text.

how are you supposed to handle the lists?
i do not see textboxes will they contain some text within the line they are located?
what if there is a picture in there or a table?
i see a heading in the top picture do you just omit that?

what you really need to do is do this yourself and then come back here with each little problem you get one at a time because converting documents is not a simple process, its possible its something i am very good at but i know there are literally hundreds of scenarios that pop up with just 1 document and you want this process completely automated?

its a big task and i can help and i am pretty sure others here will too but you need to start this yourself and come back with any problems you face...

show us some code....

Fair enough, I guess I'm just having issues stringing all the words together. To be honest, I'm extremely rusty on VBA code and have used it chiefly in Excel.

With the request about the text boxes aside, do you have a simple fix that can simply string all text into a giant block of text (no paragraphs or bullets)? That would suffice for the purposes of what I need, I would be able to do any formatting code with the recording function I believe.

Thank in advance if you can help.

im a bit rusty with the VBA on word.

but i would do it something like this

id first ignore all the text and get all the objects converted like bullets, tables, and anything else that is in there, create a sub for each one.

so for example bullet lists. Create a sub to loop through the list pull out the text of each one and then simply join it all together however you want and then use this sub in your MAIN loop that proccess or goes through the document looking for things to change.

lets say you want to remove all pictures, just add in your MAIN IF a picture is found just delete it etc etc...

what you will be left with is a very messy document with text and spaces all over the place, now all you need to do is change all tab stops to spaces, change all double spaces to single spaces (setup a recursive loop for that, just check every space in front and if its a space delete it and recal the recursive funtion) something like that, and then finally make sure there is a space after each fullstop.....

This job requires a step by step process, it might take a while to finish but once its done watching it work is quite satisfying.. just add some screen updates so you can watch it :D

can you post a sample document for converting?
preferably with a already converted document for comparison

the images are not adequate to test with

Quote:

---

Originally Posted by westconn1

can you post a sample document for converting?
preferably with a already converted document for comparison

the images are not adequate to test with

---

Attached is a copy of the example I'm using for manipulation, and below is the code I've come up with that works to get rid of bullets, but the issue is that each paragraph is bigger or smaller than the next/last, so I just need to identify the selections differently I suppose to recognize each paragraph and string them along into a block of text; like one big run on sentence/ paragraph.

Sub Remove_Bullets()

' Removes bullets from copied and pasted text

Selection.Range.ListFormat.RemoveNumbers NumberType:=wdNumberParagraph
End Sub
Sub Stringaling()

' To stitch all paragraphs into block text

Selection.TypeBackspace
Selection.TypeText Text:=" "
Selection.HomeKey Unit:=wdLine

Selection.TypeBackspace
Selection.TypeText Text:=" "
Selection.MoveUp Unit:=wdLine, Count:=1
Selection.HomeKey Unit:=wdLine

Selection.TypeBackspace
Selection.TypeText Text:=" "
End Sub

Attachment 153727
Attachment 153723

Example Document to convert:
Attachment 153725

Example Document after manipulations:
Attachment 153721

:)So, I kinda got things moving along in this... but it's not perfect. It's about 85% accurate. I'd still like to have to not do any manual manipulations as some documents would be tens of thousands of words. Any alterations would be greatly appreciated.:afrog:

Code:

---

Sub Combine_Para()

    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = "^p"
        .Replacement.Text = " "
        .Forward = True
        .Wrap = wdFindAsk
     
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
End Sub

---

Also, if anybody can throw in additional code to omit any words under 4 characters long would be fantastic!:wave::wave::wave:

Nice we have some code :) albeit a little vague, looks like a recorded macro or at least parts of one....

for this to work on any document your going to have to get your hands a little dirtier and start using the objects within word...

for example

documents, paragraphs, sentences etc, this way you dont need to know how big the document is.

Code:

---

For Each oPara In ActiveDocument.Paragraphs
  If oPara.Range.ListFormat.ListType = WdListType.wdListBullet Then
      'You just found a bullet do something with it
  End If
Next

---

here a LINK which i think you will like, it has a quick and easy way to remove paragraph markers, spaces etc.

and here is the word documentation in case you feel like studying :) MSDN

let me know if your having a problem with this code and the links but its pretty straight forward

Quote:

---

omit any words under 4 characters

---

you can try like

Code:

---

For Each wd In Selection.Words
    Debug.Print wd.Text  ' not required, just handy to see what is going on, when testing
    If Not wd.Text = vbCr And wd.Characters.Count < 4 Then wd.Delete
Next

---

i prevented this from deleting paragraph markers, as you are already doing this and with this method, it will join the preceding and following words into a single word, so no good, although an extra line could incorporate this in the same routine

Code:

---

For Each wd In Selection.Words
    Debug.Print wd.Text  ' not required, just handy to see what is going on, when testing
    if wd.text = VbCr then wd.text = " "
    If  wd.Characters.Count < 4 Then wd.Delete
Next

---

After inserting your code, it solved the issue with the extra spaces in the document, however words such as: The, who, and, has etc. are still present in the document and I can't figure out why. Also, some words have been attached to other words -- presumably because there was an omission and no space. I've attached the pictures below.

Thank you for being patient as I try to learn this stuff.

Before running your code above:
Attachment 153775

After running your code above:
Attachment 153777

I think what is going on is with the portion of the code that reads:

Code:

---

For Each wd In Selection.Words
    Debug.Print wd.Text  ' not required, just handy to see what is going on, when testing
    if wd.text = VbCr then wd.text = " "
    If  wd.Characters.Count < 5 Then wd.Delete ' I changed "4" to "5" and it fixed the issue with the 3 letter words still being present.
Next

---

:wave::wave::wave:

The code is deleting punctuation marks of all kinds -- which is okay for this code however, it is not leaving a space after deletion of punctuation so words are being fused together.

How can I get that to not fuse? I know the answer has to be simple but I can't see it.:confused::confused::confused:

i think that in some cases each word may include the trailing space, this may not apply if the word is followed by a punctuation mark rather than a space, the punctuation mark becomes a separate word, this includes hyphens and web addresses
this can easily be determined using either

Code:

---

s=0
if right(wd.text, 1) = " " then s = 1  ' only checks for a space at the end of the string
If  wd.Characters.Count < 4 + s Then wd.Delete
'or
if not len(trim(wd.text)) = wd.characters.count then

---

you could have a helper function to not delete certain punctuation

Code:

---

Function ispunctuation(w As String) As Boolean
Dim s As String
s = "!@#$<>_-://,."  ' add anything else you like to the string, the :// will work for :, / and :// as in http://
If InStr(s, w) > 0 Then ispunctuation = True: exit function
'you could also test here for any other short words you might want to keep
End Function

---

call like

Code:

---

If Not ispunctuation(wd.Text) And wd.Characters.Count < 5 Then wd.Delete

---

How and where do I place the function into the VB Editor and make sure the code uses it as a parameter. I tried placing it within and calling it, but I think I am doing something wrong because I keep getting errors.

Below is the code I'm using, it works independently at ridding the document of all formatting, but runs into the word fusing issue still:

Code:

---

Sub reduce_words()

ActiveDocument.StoryRanges(wdMainTextStory).Select ' for some reason I still have
'to manually select the text as this line will not select
'the entire text within the document like it does with other codes I use?
For Each wd In Selection.Words
    Debug.Print wd.Text  ' not required, just handy to see what is going on, when testing
    If wd.Text = vbCr Then wd.Text = " "
    If wd.Characters.Count < 5 Then wd.Delete
    Next
   
End Sub

---

Quote:

---

How and where do I place the function into the VB Editor

---

you can place the function in any module, probably the easiest is just after your sub, not in the sub

Quote:

---

ActiveDocument.StoryRanges(wdMainTextStory).Select ' for some reason I still have
'to manually select the text as this line will not select

---

it works correctly when i test it here

Whenever I run the macro it still fuses words together regardless of the function. Not sure what I'm doing wrong.

Example Document:
Attachment 153779

Code inserted into VB Editor:

Code:

---

Sub reduce_words()
ActiveDocument.StoryRanges(wdMainTextStory).Select

For Each wd In Selection.Words
    Debug.Print wd.Text  ' not required, just handy to see what is going on, when testing
    If wd.Text = vbCr Then wd.Text = " "
    If wd.Characters.Count < 5 Then wd.Delete
    Next
   
End Sub
Function ispunctuation(w As String) As Boolean
Dim s As String
s = "!@#$<>_-://,."  ' add anything else you like to the string, the :// will work for :, / and :// as in http://
If InStr(s, w) > 0 Then ispunctuation = True: Exit Function
'you could also test here for any other short words you might want to keep
End Function

---

What it looks like after running code:
Attachment 153781

What I would prefer it to look like:
Attachment 153783

Did I apply the function incorrectly? I'm sure I goofed up somewhere.:confused::confused:

Quote:

---

I'm sure I goofed up somewhere

---

quite right, you are not calling the function at all, see the last line of post #13

So I've been toying around with this for a couple days and the only thing that I could get to work was to go into the macro recorder and have it create a process to eliminate periods, commas etc.

After doing this I didn't run into the same issues with as many word fusions. Below is a picture of what it looks like now after code.:wave:

Here is the result:
Attachment 153817

Here is the Code: (If you can lean it down, I will know how to in the future: teaching moment)

Code:

---

:afrog::afrog::afrog::afrog::afrog:

Sub Recon()
' Deletes periods and commas and adds a space to end of paragraphs
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = "^p"
        .Replacement.Text = " "
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = ":"
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindAsk
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    With Selection.Find
        .Text = ","
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindAsk
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    With Selection.Find
        .Text = "."
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindAsk
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    With Selection.Find
        .Text = ";"
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindAsk
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    Call reduce_words
   
End Sub

Sub reduce_words()
ActiveDocument.StoryRanges(wdMainTextStory).Select

For Each wd In Selection.Words
    Debug.Print wd.Text  ' not required, just handy to see what is going on, when testing
   
    If wd.Text = vbCr Then wd.Text = "  "
   
    If wd.Characters.Count < 5 Then wd.Delete
   
    Next
   
End Sub

---

and yes, I know it is ugly, but I'm learning :D

you could make a loop to reduce the amount of code
this should process all the characters listed in the array
you can add any additional characters if some others need to be replaced

Code:

---

    myarr= array(";", ":", ".", ",")
Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = "^p"
        .Replacement.Text = " "
        .Forward = True
        .Wrap = wdFindContinue
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
  for i = 0 to ubound(myarr) 
    With Selection.Find
        .Text = myarr(i)
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindAsk
        .Execute Replace:=wdReplaceAll
    End With
  next
    Call reduce_words

---

Won't cover everything... but perhaps a different way?

Code:

---

Public Sub t()
    Dim wDoc As Document
    Dim wRng As Range
   
    Set wDoc = ActiveDocument
    Set wRng = wDoc.Range
    wRng.Style = "Normal"
    wRng.Bold = False
    wRng.Italic = False
    With wRng.Find
        .ClearFormatting
        .Forward = True
        .Text = vbCrLf
        .Replacement.ClearFormatting
        .Replacement.Text = " "
        .Execute Replace:=wdReplaceAll
    End With
    With wRng.Find
        .ClearFormatting
        .Forward = True
        .Text = vbCr
        .Replacement.ClearFormatting
        .Replacement.Text = " "
        .Execute Replace:=wdReplaceAll
    End With
   
    Set wDoc = Nothing
End Sub

---

since your running into problems where words are being joined together, why not as a quick fix just tell every process that changes the document to add spaces before and after the change.

then right at the end just run a process to remove all but 1?