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.

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.