Combining Word-docs based on a design in Excel

Hi there,

I'm looking for a software or a macro to do the following. I've got around 1000 Word documents, numbered 1000, 1001, 1002, etc. Every document contains one exam question. Based on a design in Excel, I want to combine the documents, so I can get different versions (files) with exam questions.

So the output of a version would be like:
Version 1 contains question 1000, 1001, 1002, 1003, etc
Version 2 contains question 1004, 1005, 1007, 1008, etc
Version 3 contains question 1012, 1013, 1014, 1015, etc
Version 4 contains question 1000, 1001, 1004, 1005, etc

I would be nice if every question could get an automatic header based on their number in the version.

Version 1:
Question 1
<<1000>>

Question 2
<<1001>>

etc..

Does anybody know if this is possible? You'll find the example of the Excel sheet attached.

Thanks in advance.

If you put all the documents in the same folder, you could run the following macro from Excel to create the documents that reflect the five versions in your worksheet example. The macro will still work if you expand the table. Change the two paths to reflect where the documents are stored and where you want the Versions stored.

Code:

---

Option Explicit

Sub CreateTest()
Dim wdApp As Object
Dim wdDoc As Object
Dim oRng As Object
Dim LastCol As Long, LastRow As Long, i As Long, j As Long
Dim xlSheet As Worksheet
Const strDocsPath As String = "C:\Path\Docs\"
Const strPath As String = "C:\Path\"
    On Error Resume Next
    Set wdApp = GetObject(, "Word.Application")
    If Err Then
        Set wdApp = CreateObject("Word.Application")
    End If
    On Error GoTo 0
    Set xlSheet = ActiveSheet
    With xlSheet
        LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
        LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
    End With
    For i = 2 To LastCol
        Set wdDoc = wdApp.Documents.Add
        For j = 2 To LastRow
            If xlSheet.Cells(j, i) > 0 Then
                wdDoc.Range.InsertAfter "Question " & xlSheet.Cells(j, i) & vbCr
                Set oRng = wdDoc.Range
                oRng.collapse 0
                oRng.InsertFile Filename:=strDocsPath & xlSheet.Cells(j, 1) & ".docx"
                wdDoc.Fields.Unlink
                Set oRng = wdDoc.Range
            End If
        Next j
        wdDoc.saveas2 Filename:=strPath & xlSheet.Cells(1, i) & ".docx"
        wdDoc.Close 'Optional
    Next i
    MsgBox "Documents created at " & strPath
lbl_Exit:
    Set xlSheet = Nothing
    Set wdApp = Nothing
    Set wdDoc = Nothing
    Set oRng = Nothing
    Exit Sub
End Sub

---

Thanks for the quick reply! It seems to work fine. Only three things:
1. Sometimes the style changes (more white space between rows and font style and size changes).
2. If a question can't fit on one page, the entire question should be on the next page.
3. The order of the questions in Word should be like the numbers in the Excel. Now I get question 1, 2, 6, 4, 3, 8, 5, 7. It should be 1, 2, 3, 4, 5, 6, 7, 8.

It probably needs some more code I guess? :)

1 - This is not attributable to the macro, and is probably the result of formatting variations in the question documents. I have introduced some formatting using styles from the normal template and replaced any instances of double paragraph breaks in the inserted documents with one break. That's as good as it gets without knowing the exact nature of the problem.
2 - That is much easier said than done, as the length of the questions is unknown. The modified version keeps the question heading with the first paragraph of the question.
3 - My fault - a misreading of the requirement. Fixed below.

Code:

---

Sub CreateTest()
Dim wdApp As Object
Dim wdDoc As Object
Dim oRng As Object
Dim LastCol As Long, LastRow As Long
Dim i As Long, j As Long, k As Long
Dim iQuestion As Long
Dim xlSheet As Worksheet
Const strDocsPath As String = "C:\Path\Docs\"
Const strPath As String = "C:\Path\"
    On Error Resume Next
    Set wdApp = GetObject(, "Word.Application")
    If Err Then
        Set wdApp = CreateObject("Word.Application")
        Err.Clear
    End If
    wdApp.ScreenUpdating = False
    Set xlSheet = ActiveSheet
    With xlSheet
        LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
        LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
    End With
    For i = 2 To LastCol
        iQuestion = 0
        Set wdDoc = wdApp.Documents.Add
        For j = 2 To LastRow
            If xlSheet.Cells(j, i) > 0 Then
                iQuestion = iQuestion + 1
                Set oRng = wdDoc.Range
                oRng.collapse 0
                oRng.Text = "Question " & iQuestion & vbCr
                oRng.Style = "Heading 2"
                oRng.ParagraphFormat.keepwithnext = True
                oRng.collapse 0
                oRng.InsertFile Filename:=strDocsPath & xlSheet.Cells(j, 1) & ".docx"
                oRng.End = wdDoc.Range.End
                oRng.Style = "Normal"
                oRng.Text = Replace(oRng.Text, vbCr & vbCr, vbCr)
                wdDoc.Fields.Unlink
                Set oRng = wdDoc.Range
                'oRng.collapse 1
            End If
        Next j
        wdDoc.Range.Font.Reset
        wdDoc.Range.Style.Reset

        wdDoc.SaveAs2 Filename:=strPath & xlSheet.Cells(1, i) & ".docx"
        wdDoc.Close        'Optional
        DoEvents
    Next i
    MsgBox "Documents created at " & strPath
    wdApp.ScreenUpdating = True
lbl_Exit:
    Set xlSheet = Nothing
    Set wdApp = Nothing
    Set wdDoc = Nothing
    Set oRng = Nothing
    Exit Sub
End Sub

---