Need to copy values from other documents based on heading name and create a new document through VBA
Hi,
I my company i am working for a Department. This Department has 4 Divisions. Each Division will send their Weekly Highlights to My Department. I will select important topics from the 4 Word Documents which i recieved from Division and i place it in a new Document, this new document wil be send to the management.
For example Each Division has a Heading named
'Productivity & Improvement And Cost Savings'
'HRD22 Gain'
under that they may have a heading containing the word 'HRD22 Gain' like this. So i have to pick all the paragraph which contains the word 'Gain' in their heading which come under 'Productivity & Improvement And Cost Savings'. Similar to the Example i said i have some more headings and some more sub headings which i have to do.
Every week i am doing this repeated process. I like to automate this. Is it possible to write VBA code. Where i can get a similar example or forum which could guide me.
I think when i open a new document and run the macro - all the required headings & paragraphs will copied from the four divisions will be pasted in this newly opened document. The code should do this or any other suggestions please.
Thanks,
Chock.
I tried to first change the heading of the Source Doc to change the Font Style from 'Palatino Linotype' to 'Heading2'. But in the word doc i can't found the heading2 style.
Font and Style are two different things. When you generate a new document you should see “Normal” on the leftmost side of the formatting toolbar. Click the down arrow and you will see Heading styles.
more over, i don't want to cut the paragraph as you have given
Selection.Cut
Just i need to copy the content and paste here.
You will find that changing to Selection.Copy sends the code into an endless loop. You could likely redesign the code to somehow use .Wrap = wdFindStop rather than .Wrap = wdFindContinue
If opening in read-only is not safe enough, you could make copies of the source documents to work on.
Initially my summary doc should have 7 headings. as below
Gains
Meetings
Workover
Safety
HR
SOP
Drilling
Until you refine the code, you will run the macro seven times, each time moving the insertion point below the next heading before the next run.
Should i create a new macro and paste your code and run or what. I tried that, but it didn't work. I think because the source is not in the "Heading 2" style.
While in the editor from the Insert menu, insert a module and paste the code there.
Hi ,
Thanks for the code. Its working fine. Hope it will solve all my issues.
Each Divison will send in the own format, is there any way to find all paragraph heading and change their heading from their original style to other. so it will be easy for me to run your code.
The company may feel the file is confidentail, so i am not attaching it hear. if u like u can give ur id, i will send it to u, or take my its itchok@rediffmail.com. Macros/VBA::
How to prevent other users from seeing and changing your VBA code when I create a new instance of Word, open a Word document or create a new one?
http://word.mvps.org/faqs/macrosvba.htmHOME |
To replace all instances of Heading 1 with your own Heading 6 try this.
Sub findHdgReplace()
Selection.find.ClearFormatting
Selection.find.Style = ActiveDocument.Styles("Heading 1")
Selection.find.Replacement.ClearFormatting
Selection.find.Replacement.Style = ActiveDocument.Styles("Heading 6")
With Selection.find
.Text = ""
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = True
End With
Selection.find.Execute Replace:=wdReplaceAll
End Sub
Hi,
I tried to first change the heading of the Source Doc to change the Font Style from 'Palatino Linotype' to 'Heading2'. But in the word doc i can't found the heading2 style. more over, i don't want to cut the paragraph as you have given
Microsoft Word Basics ++::
Embed This Document. 1. Copy the embed code below Advanced Options. Embed Code .. how to add page numbers half way through a word doc
http://www.scribd.com/doc/3476765/Microsoft-Word-Basics-HOME |
Word VBA Techniques::
File Format: PDF/Adobe Acrobat - View as HTMLDocuments(1).Activate. Documents("Report.doc").Activate document is assembled by concatenating the chapter files with VBA code and saved as a single
http://www.susandoreydesigns.com/software/WordVBATechniques.pdfHOME |
Selection.Cut
Just i need to copy the content and paste here.
Initially my summary doc should have 7 headings. as below
Gains
Meetings
Workover
Safety
HR
SOP
Drilling
Each division is sending in different font style. finally i will change to 'PlatinoPalatino Linotype'. I think you select the paragraph from source doc based on the Font Style "Heading 2"
Should i create a new macro and paste your code and run or what. I tried that, but it didn't work. I think because the source is not in the "Heading 2" style.
Now atleast i come to know its possible to do this job through macro. Thanks skatonni.
Hope it will be easy if i understand a little bit more.
Thanks,
Chock.
Hi,
I open two documents one is the Source and the other is the destination(which is blank when i open). I changed the paragraph headings style to "Heading 6" in the Source file. But when i run the summaryGain(), its picking a paragraph heading and pasting and doing it continuously, so it gets hang and i need to close it through Task Manager - End Task.
Public selFound As Boolean
Sub summaryGain()
Dim summaryDoc As Document
Dim hdgStyle As String
Dim target As String
Dim openDoc As Document
Set summaryDoc = ActiveDocument
Application.ScreenUpdating = False
hdgStyle = "Heading 6"
target = "drilling"
For Each openDoc In Documents
If openDoc <> summaryDoc Then
findAgain:
openDoc.Activate
findGainHdg2 hdgStyle, target
If selFound = True Then
summaryDoc.Activate
Selection.TypeParagraph
Selection.TypeText Text:="From " & openDoc.Name
Selection.TypeParagraph
Selection.Paste
GoTo findAgain
End If
End If
Next openDoc
summaryDoc.Activate
Application.ScreenUpdating = True
End Sub
Sub findGainHdg2(fhdgStyle As String, ftarget As String)
selFound = False
Selection.Find.ClearFormatting
Selection.Find.Style = ActiveDocument.Styles(fhdgStyle)
With Selection.Find
.Text = ftarget
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
If Selection.Find.Execute = True Then ' something found
selFound = True
Selection.HomeKey Unit:=wdLine
Selection.MoveDown Unit:=wdParagraph, Count:=2, Extend:=wdExtend
Selection.Copy
End If
Selection.Find.ClearFormatting
End Sub
I found by running the Macro in Debug Mode (by pressing F8) that its pasting the same content repeatedly and endless. Kindly correct me to proceed the search for the whole document copy and paste in to the destination file.
From APED 09-19-2006.doc
DRILLING AND WORKOVER ACTIVITIES:
From APED 09-19-2006.doc
DRILLING AND WORKOVER ACTIVITIES:
From APED 09-19-2006.doc
DRILLING AND WORKOVER ACTIVITIES:
From APED 09-19-2006.doc
DRILLING AND WORKOVER ACTIVITIES:
Thanks,
Chock.
See if this gets you started.
Public selFound As Boolean
Sub summaryGain()
' Open all the source documents (or one at a time) preferably in read-only
' Generate a blank document or open a previously saved/started summary document
' Run the program as many times as necessary, from the summmary document
' changing the Heading style and target to Find as required
Dim summaryDoc As Document
Dim hdgStyle As String
Dim target As String
Dim openDoc As Document
Set summaryDoc = ActiveDocument
Application.ScreenUpdating = False
hdgStyle = "Heading 2"
target = "gain"
For Each openDoc In Documents
If openDoc <> summaryDoc Then
findAgain:
openDoc.Activate
findGainHdg2 hdgStyle, target
If selFound = True Then
summaryDoc.Activate
Selection.TypeParagraph
Selection.TypeText Text:="From " & openDoc.Name
Selection.TypeParagraph
Selection.Paste
GoTo findAgain
End If
End If
Next openDoc
summaryDoc.Activate
Application.ScreenUpdating = True
End Sub
Sub findGainHdg2(fhdgStyle As String, ftarget As String)
selFound = False
Selection.find.ClearFormatting
Selection.find.Style = ActiveDocument.Styles(fhdgStyle)
With Selection.find
.Text = ftarget
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
If Selection.find.Execute = True Then ' something found
selFound = True
Selection.HomeKey Unit:=wdLine
Selection.MoveDown Unit:=wdParagraph, Count:=2, Extend:=wdExtend
Selection.Cut
End If
Selection.find.ClearFormatting
End Sub
I open two documents one is the Source and the other is the destination(which is blank when i open). I changed the paragraph headings style to "Heading 6" in the Source file. But when i run the summaryGain(), its picking a paragraph heading and pasting and doing it continuously, so it gets hang and i need to close it through Task Manager - End Task.
I found by running the Macro in Debug Mode (by pressing F8) that its pasting the same content repeatedly and endless.
To stop an endless loop use ctrl + break.
Kindly correct me to proceed the search for the whole document copy and paste in to the destination file.
As I indicated previously it would not be as simple as changing Cut to Copy.
The best I can do is to ensure the source documents are read only.
Sub summaryDrilling()
' Generate a blank document or open a previously saved/started summary document
' Run the program as many times as necessary, from the summmary document
' changing the Heading style and target to Find as required
Dim summaryDoc As Document
Dim hdgStyle As String
Dim target As String
Dim openDoc As Document
Dim openDocNameArr() As String
Dim docCount As Integer
Dim numDoc As Integer
Dim filePathName As String
Set summaryDoc = ActiveDocument
docCount = Documents.Count
ReDim openDocNameArr(Documents.Count)
For numDoc = 1 To docCount
openDocNameArr(numDoc) = Documents(numDoc).FullName
Next numDoc
Application.ScreenUpdating = False
For numDoc = 1 To docCount
Documents(openDocNameArr(numDoc)).Activate
If ActiveDocument <> summaryDoc Then
If ActiveDocument.ReadOnly = False Then
filePathName = ActiveDocument.FullName
ActiveDocument.Close Savechanges:=wdDoNotSaveChanges
Documents.Open FileName:=filePathName, ReadOnly:=True
End If
End If
Next numDoc
hdgStyle = "Heading 6"
target = "drilling"
For Each openDoc In Documents
If openDoc <> summaryDoc Then
findAgain:
openDoc.Activate
findGainHdg2 hdgStyle, target
If selFound = True Then
summaryDoc.Activate
Selection.TypeParagraph
Selection.TypeText Text:="From " & openDoc.Name
Selection.TypeParagraph
Selection.Paste
GoTo findAgain
End If
End If
Next openDoc
summaryDoc.Activate
Application.ScreenUpdating = True
End Sub
From APED 09-19-2006.doc
DRILLING AND WORKOVER ACTIVITIES:
From APED 09-19-2006.doc
DRILLING AND WORKOVER ACTIVITIES:
It appears there is an empty paragraph below the Heading. You'll have to accommodate this by adjusting the selection.
Selection.MoveDown Unit:=wdParagraph, Count:=3, Extend:=wdExtend
Hi,
The code does the trick. It works fine for changing all headings styles. One more (AND) condition i need to add with the current code which you have given to cut & paste from source document.
Now we supply Word "Drilling" through ftarget variable to check if it is in the paragraph heading, if yes then it cuts the paragraph and pasting in the Summary Document.
The additional condition i need to add here is, if it finds the word "Drilling" in the paragraph heading, it should additionally check a condition whether this paragraph is highlighted (i.e if a particular paragraph's background is shaded with yellow).
By default in the Summary Document i will add the headings with equal spaces as below.
Drilling:
Human Resources:
Workover:
If i pass the "Drilling" word in the ftarget variable then the code should find and cut the paragraph which contains the word "Drilling" and background in Yellow color.
This should be placed under Drilling: in the Summary Document if the ftarget variable contains "Drilling" else it should be placed in Human Resources: in Summary Document if ftarget has "Human Resources". Kindly help me to solve this.
Thanks,
Chock.
Hi,
Also tell me that where i have place your code and test whether by creating a new macro and running it or by placing it in the ThisDocument area in the Visual Basic Editor.
Thanks,
Chock.
 I Am a Sinner – What About You?
 Global Sourcing and Supplier Online by Dylan
|
Copy from 1 doc to other doc based on heading name and create a new doc thru VBA code