Option Explicit

Private Const sName As String = "Billy|Melanie|John|Susan|Ted|Christine|Bobby"
Private Const sPlace As String = "cliff|tower|bridge|building"
Private Const sItem As String = "stone|rock|wrench|box|crate|suitcase"

Private Const iPages As Integer = 10 'the number of pages to create

Private vName As Variant, vPlace As Variant, vItem As Variant
Private iPlace As Integer, iName As Integer, iItem As Integer
Private iHeight As Double, iMass As Double
Private i As Integer
Private oxlApp As Object    ' Used for the Excel App
Private oxlWbk As Object    ' Used for the Workbook
Private FN As String
Private oDoc As Document
Private oRng As Range
Private sText As String
Private NextRow As Long
Private AnswerA As Single    ' Part A solution
Private AnswerB As Single    ' Part B solution
Private AnswerC As Single    ' Part C solution

Sub anticopy()

    Set oDoc = Documents.Add
    Set oRng = oDoc.Range

    FN = Environ("USERPROFILE") & "\documents\vba"    ' Spreadsheet Folder
    CreateFolders FN
    FN = FN & "testanswers.xlsx"
    Set oxlApp = CreateObject("Excel.Application")
    If FileExists(FN) Then    ' Check to see if the spreadsheet exists.
        Set oxlWbk = oxlApp.Workbooks.Open(FileName:=FN)    ' Open the Workbook
    Else    ' It does not exist so tell the user.
        Set oxlWbk = oxlApp.Workbooks.Add
        With oxlWbk
            .Sheets(1).Cells(1, 1).Value = "Student"
            .Sheets(1).Cells(1, 2).Value = "AnswerA"
            .Sheets(1).Cells(1, 3).Value = "AnswerB"
            .Sheets(1).Cells(1, 4).Value = "AnswerC"

            .SaveAs FN
        End With
    End If

    vName = Split(sName, "|")
    vPlace = Split(sPlace, "|")
    vItem = Split(sItem, "|")

    For i = 1 To iPages    'create the question documents
        iHeight = RandomNumber(20, 80, 1)
        iMass = RandomNumber(2, 25, 0)
        iPlace = RandomNumber(0, UBound(vPlace))
        iName = RandomNumber(0, UBound(vName))
        iItem = RandomNumber(0, UBound(vItem))

        AnswerA = iMass * 9.8
        AnswerB = ((2 * iHeight) / 9.8) ^ 0.5
        AnswerC = 9.8 * AnswerB
        sText = "Student " & i & vbCr & vName(iName) & " dropped a " & vItem(iItem) & " off a " & iHeight & " meter-high " & _
                vPlace(iPlace) & ". The " & vItem(iItem) & " has a mass of " & iMass & " kilograms." & _
                Chr(11) & Chr(9) & "A. Calculate the force of gravity on the " & vItem(iItem) & "." & Chr(11) & _
                Chr(9) & "B. Calculate the time it will take to hit the ground. Ignore air resistance." & _
                Chr(11) & Chr(9) & "C. How fast will the " & vItem(iItem) & " be falling when it hits the ground?" & _
                Chr(11)
        oRng.Text = sText
        oRng.Collapse 0
        If i < iPages Then
            oRng.InsertBreak Type:=0
            oRng.Collapse 0
        End If

        NextRow = oxlWbk.Sheets(1).Range("A" & oxlWbk.Sheets(1).Rows.Count).End(-4162).Row + 1

        With oxlWbk
            .Sheets(1).Cells(NextRow, 1).Value = "Student " & i
            .Sheets(1).Cells(NextRow, 2).Value = AnswerA
            .Sheets(1).Cells(NextRow, 3).Value = AnswerB
            .Sheets(1).Cells(NextRow, 4).Value = AnswerC
        End With
    Next i

    oxlWbk.Close SaveChanges:=True    ' Close the spreadsheet, saving the changes.
    Set oxlWbk = Nothing
    ' Close the Excel App cleanly
    oxlApp.Quit
    Set oxlApp = Nothing
End Sub

Private Function RandomNumber(Lowest As Long, Highest As Long, _
                              Optional Decimals As Integer) As Integer
    If IsMissing(Decimals) Or Decimals = 0 Then
        Randomize
        RandomNumber = Int((Highest + 1 - Lowest) * Rnd + Lowest)
    Else
        Randomize
        RandomNumber = Round((Highest - Lowest) * Rnd + Lowest, Decimals)
    End If
End Function

Private Function FileExists(FName As String) As Boolean
' Returns True if the file FName exists, else False
Dim fs
    Set fs = CreateObject("Scripting.FileSystemObject")
    FileExists = fs.FileExists(FName)
    Set fs = Nothing
End Function

Private Sub CreateFolders(strPath As String)
'A Graham Mayor/Greg Maxey AddIn Utility Macro
Dim oFSO As Object
Dim lngPathSep As Long
Dim lngPS As Long
  If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
  lngPathSep = InStr(3, strPath, "\")
  If lngPathSep = 0 Then GoTo lbl_Exit
  Set oFSO = CreateObject("Scripting.FileSystemObject")
  Do
    lngPS = lngPathSep
    lngPathSep = InStr(lngPS + 1, strPath, "\")
    If lngPathSep = 0 Then Exit Do
    If Len(Dir(Left(strPath, lngPathSep), vbDirectory)) = 0 Then Exit Do
  Loop
  Do Until lngPathSep = 0
    If Not oFSO.FolderExists(Left(strPath, lngPathSep)) Then
      oFSO.CreateFolder Left(strPath, lngPathSep)
    End If
    lngPS = lngPathSep
    lngPathSep = InStr(lngPS + 1, strPath, "\")
  Loop
lbl_Exit:
  Set oFSO = Nothing
  Exit Sub
End Sub