Search for files in folder, copy inside and paste it in main document!

[linneedshelp]

Hello!

I am new in VBA Word and I am struggling with the code, would be great to get some help. : pray2:

I have a folder1 with a Word Document and another folder2 inside. The Word Document is the "Main Document", in it there are headings and after each heading there is the name of the document which belongs to this part. In the folder2 there are a lot of Word Documents, the "Part Documents" which are the Documents belonging to the different headings.

EXAMPLE OF FOLDERS:

Folder1 > Main Document & "Folder2 Parts" > "Part1.docx" & "Part2.docx" & "Part3.docx" & .....


MAIN DOCUMENT:

In the Main Document there is this text:

1. Heading 1

Part1.docx

2. Heading 2

Part2.docx

3. Heading 3

Part3.docx


FUNCTION:

Open the Main Document, start the macro, macro begins to search for the variable in the Main document, it finds "Part1.docx", then it goes to the folder2 and searches for the corresponding file with the same name, it copies the inside and replaces the word Part1.docx in the main document for the text inside the file.
Then, the macro searches for the next variable, it finds Part2.docx and goes again to the folder2, searches and finds the file Part2.docx and replaces the word found in the main document for the text which is in the file found in folder2.

Has anyone of you and idea how to do this? I hope I explained myself good enough.

Any suggestions would be appreciated!

[gmayor]

Maybe something like

Option Explicit

Sub Example()
'Graham Mayor
Dim oRng As Range
Dim oPara As Paragraph
Dim strFname As String
Const strPath As String = "C:\Path\Folder2\" 'the path with the sub documents
For Each oPara In ActiveDocument.Paragraphs
Set oRng = oPara.Range
oRng.End = oRng.End - 1
If LCase(oRng.Text) Like "part*.docx" Then
strFname = oRng.Text
oRng.Text = ""
If FileExists(strPath & strFname) Then
oRng.InsertFile strPath & strFname
End If
End If
Next oPara
lbl_Exit:
Set oPara = Nothing
Set oRng = Nothing
Exit Sub
End Sub

Private Function FileExists(strFullName As String) As Boolean
'Graham Mayor
'strFullName is the name with path of the file to check
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.FileExists(strFullName) Then
FileExists = True
Else
FileExists = False
End If
lbl_Exit:
Exit Function
End Function

[linneedshelp]

Hello Graham Mayor,

Thank you really much. This is awesome!

[linneedshelp]

Hello,

It´s me again. I worked on your macro and now I have the problem that it is not fast enough for big amounts of Word Documents Parts.

The case is: There are a lot of people working on this Main Doument, everyone does one Part...docx and paste it in the Folder2, as everyone uses another Format (like Font Size, Font Name, Headings) I have to format the text after it is paste in the Main Document. Also I wanted to add page numbers.

I managed to add all this to your macro but it is just working with small documents. As there are going to be more or less 15 part documents with around 5-10 pages each, I used old word documents I found in my computer, named then Part1.docx to Part6.docx and tried the macro. What happend is that it ran 10 minutes and still nothing happend.

I tried tifferent scenarios:

1) 6 Part Documents with around 35 pages in total just with your code: it worked
2) 6 Part Documents .... with Formatting: not working
3) 2 Part Documents .... with Formatting: working

I belive it is because as I wrote the macro (going to paste it below), it goes through the Main Document, finds Part1.docx, goes to the Folder2, searches for the File Part1.docx and paste the text inside the Main Document. The macro repeats this until he does not find anymore Part().docx.
Now, the macro starts to search for Heading1, everytime it is found its style is changed. This means the macro runs through the Main Document (maybe over 80 Pages) just for searching Heading 1. Then it goes through the main document again, just for searching Heading 2, and after that again just for changing the format of the text (Normal).

So, basically the macro has to go 3 times through all the Main document. Am I right that the macro is lazy because of that?
Is there a posibility to put all these 3 things into a big If-Clause?

Like: search for x, if x = Heading 1 do that, else if x = Heading 2 do that else, if x = Normal do that else end if
Because this would me the macro just has to go through the Document one time.

CODE WITH ADDITIONAL FUNCTIONS:




Sub Example()







' Graham Mayor






Application.ScreenUpdating = False






Dim oRng As Range



Dim oPara As Paragraph


Dim strFname As String



Const strPath As String = " C:\Path\Folder2\" 'the path with the sub documents



For Each oPara In ActiveDocument.Paragraphs


Set oRng = oPara.Range


oRng.End = oRng.End - 1


If LCase(oRng.Text) Like "part*.docx" Then


strFname = oRng.Text


oRng.Text = ""


If FileExists(strPath & strFname) Then


oRng.InsertFile strPath & strFname


End If


End If


Next oPara

'CHANGE HEADING 1


With ActiveDocument.Content.Find


.ClearFormatting


.Style = wdStyleHeading1


'The Do...Loop statement repeats a series of actions each time this style is found.






Do While .Execute(Forward:=True, Format:=True) = True


With .Parent


.Font.Bold = False


.Font.Name = "Time New Roman"


.Font.ColorIndex = wdBlack


.Font.Size = 16


.Font.Underline = True


.ParagraphFormat.Alignment = wdAlignParagraphLeft


.ParagraphFormat.SpaceAfter = 6






End With


Loop


End With


'CHANGE HEADING 2


With ActiveDocument.Content.Find


.ClearFormatting


.Style = wdStyleHeading2


'The Do...Loop statement repeats a series of actions each time this style is found.






Do While .Execute(Forward:=True, Format:=True) = True


With .Parent


.Font.Bold = False


.Font.Name = "Time New Roman"


.Font.ColorIndex = wdBlack


.Font.Size = 14


.Font.Underline = True


.ParagraphFormat.Alignment = wdAlignParagraphLeft


.ParagraphFormat.SpaceAfter = 6






End With


Loop


End With


'CHANGE NORMAL


With ActiveDocument.Content.Find


.ClearFormatting


.Style = wdStyleNormal


'The Do...Loop statement repeats a series of actions each time this style is found.






Do While .Execute(Forward:=True, Format:=True) = True


With .Parent


.Font.Bold = False


.Font.Name = "Time New Roman"


.Font.ColorIndex = wdBlack


.Font.Size = 12


.Font.Underline = False


.ParagraphFormat.Alignment = wdAlignParagraphJustify


.ParagraphFormat.SpaceAfter = 6






End With


Loop


End With

'ADD PAGE NUMBER


With ActiveDocument.Sections(1)


.Footers(wdHeaderFooterPrimary).PageNumbers.Add _


PageNumberAlignment:=wdAlignPageNumberCenter, _


FirstPage:=True


End With


lbl_Exit:


Set oPara = Nothing


Set oRng = Nothing


Exit Sub


End Sub






Private Function FileExists(strFullName As String) As Boolean




'Graham Mayor





'strFullName is the name with path of the file to check


Dim fso As Object


Set fso = CreateObject("Scripting.FileSystemObject")


If fso.FileExists(strFullName) Then


FileExists = True


Else


FileExists = False


End If


lbl_Exit:


Exit Function


End Function

[gmayor]

If you have a lot of paragraphs to process it is inevitably slow, in which case Range.Find is faster. Try the following


Option Explicit

Sub Example()
' Graham Mayor
Dim oRng As Range
Dim strFname As String
Const strPath As String = "C:\Path\Folder2\" 'the path with the sub documents
Application.ScreenUpdating = False
'ADD PAGE NUMBER
With ActiveDocument.Sections(1)
.Footers(wdHeaderFooterPrimary).PageNumbers.Add _
PageNumberAlignment:=wdAlignPageNumberCenter, _
FirstPage:=True
End With
Set oRng = ActiveDocument.Range
With oRng.Find
Do While .Execute(FindText:="Part[0-9]{1,}.docx", MatchWildcards:=True)
strFname = oRng.Text
If FileExists(strPath & strFname) Then
oRng.Text = ""
oRng.InsertFile strPath & strFname
End If
oRng.Collapse 0
Loop
End With
SetStyles ActiveDocument
lbl_Exit:
Set oRng = Nothing
Exit Sub
End Sub

Private Function FileExists(strFullName As String) As Boolean
'Graham Mayor
'strFullName is the name with path of the file to check
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.FileExists(strFullName) Then
FileExists = True
Else
FileExists = False
End If
lbl_Exit:
Exit Function
End Function

Sub SetStyles(odoc)
Dim oStyle As Style
For Each oStyle In odoc.Styles
Select Case oStyle.NameLocal
Case Is = "Heading 1"
With oStyle
.Font.Bold = False
.Font.Name = "Time New Roman"
.Font.ColorIndex = wdBlack
.Font.Size = 16
.Font.Underline = wdUnderlineSingle
.ParagraphFormat.Alignment = wdAlignParagraphLeft
.ParagraphFormat.SpaceAfter = 6
End With
Case Is = "Heading 2"
With oStyle
.Font.Bold = False
.Font.Name = "Time New Roman"
.Font.ColorIndex = wdBlack
.Font.Size = 14
.Font.Underline = True
.ParagraphFormat.Alignment = wdAlignParagraphLeft
.ParagraphFormat.SpaceAfter = 6
End With
Case Is = "Normal"
With oStyle
.Font.Bold = False
.Font.Name = "Time New Roman"
.Font.ColorIndex = wdBlack
.Font.Size = 12
.Font.Underline = False
.ParagraphFormat.Alignment = wdAlignParagraphJustify
.ParagraphFormat.SpaceAfter = 6
End With
Case Else
End Select
Next oStyle
lbl_Exit:
Exit Sub
End Sub

[linneedshelp]

Hello,

Thank you for replying.

I feel sorry to ask again but on my Word it's not working completely.

If I copy exact your macro, the programm says there is an Error 5560 because the "search for" method it is not a valid comparison... Do While .Execute(FindText:="Part[0-9]{1,}.docx", MatchWildcards:=True)

I changed it to Do While .Execute(FindText:="Part*.docx", MatchWildcards:=True) as it was before and then the macro copies and places the text into the Main document but the formatting is not working. I understand the part of calling SetStyles ActiveDocument and tried to place it somewhere else to make it work but I couldn't find a solution.

Is it actually working on your computer?

[gmayor]

I assume the error occurs because your local Windows regional settings use a semicolonn rather than a comm as list separator. Change the line to

Do While .Execute(FindText:="Part[0-9]{1;}.docx", MatchWildcards:=True)
The SetStyles macro re-assigns the paragraph styles using the formats from your request. It works fine here, but then I don't have your documents so am unable to judge what you have done with styles in your documents that would prevent it from working.

[linneedshelp]

Hello,

I found the problem!!!

By the time I was working on the first Macro you send me, I tried to add the formatting using the German word or the English word for it. (My Word is in German)
But just the English word "Heading1" in wdStyleHeading1 worked.

The new macro needs the German word: Case Is = "Überschrift 1".

Thank you for helping me!

[gmayor]

There was nothing in your original question to suggest a language issue, but that would certainly screw things up. I recently did some work for a private client in Dutch which gave me a headache for much the same reason. You need to insert the local style names as you appear to have discovered. That and the list separator character.:)