Combining Word-docs based on a design in Excel

[haste]

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.

[gmayor]

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.

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

[haste]

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? :)

[gmayor]

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.


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