Sub verbatim_crosstab()
MaxRow = Determine_Max_Row()
crosstabtrue = InputBox("Is there cross tabulation? (Y/N)", , "N")
If LCase(crosstabtrue) = "y" Then
Sheets(1).Activate
UserForm1.Label2.Caption = "Determining Cross Tab Columns"
crosstabcount = moveCrossTabs()
UserForm1.Label2.Caption = "Moving Questions Into One Column"
totalrows = OneColumn(MaxRow)
UserForm1.Label2.Caption = "Deleting Empty Rows"
UserForm1.Repaint
deleted = RemoveEmpty(totalrows)
deleted = RemoveEmpty(totalrows)
deleted = RemoveEmpty(totalrows)
deleted = RemoveEmpty(totalrows)
deleted = RemoveEmpty(totalrows)
Sheets(1).Activate
UserForm1.Label2.Caption = "Determining Cross Tab Values For Each Column"
For x = 2 To 1000
If Cells(1, x) = Empty Then
Exit For
End If
prompt = InputBox("What is " + Cells(1, x) + "?(For Example: Job Title)", , "")
y = ReplaceTitles(prompt, x, totalrows)
Next x
UserForm1.Label2.Caption = "Typing up the Word Document..."
Cells(1, 1).EntireRow.Insert
Cells(1, 1) = "XXXX"
y = CreateNewWordDoc(totalrows, crosstabcount)
Else
Sheets(1).Activate
UserForm1.Label2.Caption = "Moving Questions Into One Column"
totalrows = OneColumn_NoCrossTab
Sheets(1).Activate
UserForm1.Label2.Caption = "Deleting Empty Rows"
UserForm1.Repaint
deleted = RemoveEmpty(totalrows)
UserForm1.Label2.Caption = "Deleting Empty Rows"
UserForm1.Repaint
deleted = RemoveEmpty(totalrows)
UserForm1.Label2.Caption = "Deleting Empty Rows"
UserForm1.Repaint
deleted = RemoveEmpty(totalrows)
UserForm1.Label2.Caption = "Deleting Empty Rows"
UserForm1.Repaint
deleted = RemoveEmpty(totalrows)
UserForm1.Label2.Caption = "Deleting Empty Rows"
UserForm1.Repaint
deleted = RemoveEmpty(totalrows)
UserForm1.Label2.Caption = "Deleting Empty Rows"
UserForm1.Repaint
UserForm1.Label2.Caption = "Typing up the Word Document..."
UserForm1.Repaint
Sheets(1).Activate
Cells(1, 1).EntireRow.Insert
Cells(1, 1) = "XXXX"
Cells(1, 2) = "XXXX"
Cells(1, 3) = "XXXX"

y = CreateNewWordDoc(totalrows, 0)
End If
MsgBox ("Process Complete")
UserForm1.Hide
End Sub

Function Determine_Max_Row()
ActiveCell.SpecialCells(xlLastCell).Select
MyLastColumn = ActiveCell.column
Max = 1
Temp = 0
For x = 1 To MyLastColumn
Temp = Sheets(1).Cells(rows.Count, x).End(xlUp).Row
If Temp > Max Then
Max = Temp
End If
Next
Determine_Max_Row = Max
End Function



Function moveCrossTabs()
prompt = InputBox("Please enter the name of first cross tab question as shown in Row 1 Ex. B (QB)", , "B (QB)")
ActiveCell.SpecialCells(xlLastCell).Select
MyLastColumn = ActiveCell.column
Start = 0
Max = 1
For x = 2 To MyLastColumn
If Start > 0 Then
If Cells(1, x) = Empty Then
Exit For
Else
Start = Start + 1
Sheets(1).Columns(x).Cut Destination:=Sheets(2).Columns(Start)
Temp = Sheets(1).Cells(rows.Count, x).End(xlUp).Row
If Temp > Max Then
Max = Temp
End If
End If

End If
If Start = 0 Then
If Cells(1, x) = prompt Then
Start = Start + 1
Max = Sheets(1).Cells(rows.Count, x).End(xlUp).Row
Sheets(1).Columns(x).Cut Destination:=Sheets(2).Columns(Start)
End If
End If
Next x
moveCrossTabs = Start
End Function

Function ReplaceTitles(prompt, column, rows) As String
Sheets(1).Activate
For x = 1 To rows
If Cells(x, column) = Empty Then
Cells(x, column) = prompt + " - Not Specified"
End If
If Cells(x, column) = "Other (please specify)" Then
Cells(x, column) = prompt + " - Other"
End If
Next x

End Function


Function RemoveEmpty(rows) As Long
deleted = 0
Sheets(1).Activate
x = 1
While x < rows
If Cells(x, 1) = Empty And Cells(x + 1, 1) = Empty Then
Cells(x, 1).EntireRow.Delete
Cells(x, 1).EntireRow.Delete
deleted = deleted + 2
rows = rows - 2
End If
If Cells(x, 1) = Empty Then
Cells(x, 1).EntireRow.Delete
deleted = deleted + 1
rows = rows - 1
End If
x = x + 1
Wend
RemoveEmpty = deleted
End Function


Function OneColumn_NoCrossTab() As Long
totalrows = 0
ThisWorkbook.Save
Dim LastColumn&, LastRow&, NextRow&, xCol&
LastColumn = Range("A1").CurrentRegion.Columns.Count
Dim countofquestions
countofquestions = 1
For xCol = 2 To LastColumn
LastRow = Cells(rows.Count, xCol).End(xlUp).Row
NextRow = Cells(rows.Count, 1).End(xlUp).Row + 1
ActiveSheet.Cells(NextRow, 1) = "XXXX"
NextRow = NextRow + 1
Range(Cells(1, xCol), Cells(LastRow, xCol)).Cut Cells(NextRow, 1)


Next xCol
totalrows = Cells(rows.Count, 1).End(xlUp).Row
Application.ScreenUpdating = True
OneColumn_NoCrossTab = totalrows

End Function


Function OneColumn(MaxRow) As Long
totalrows = 0
ThisWorkbook.Save
Dim LastColumn&, LastRow&, NextRow&, xCol&
LastColumn = Range("A1").CurrentRegion.Columns.Count
Dim countofquestions
countofquestions = 1
LastRow = MaxRow
Maxrow1 = MaxRow
For xCol = 2 To LastColumn
NextRow = Maxrow1 + 1
ActiveSheet.Cells(NextRow, 1) = "XXXX"
NextRow = NextRow + 1
Maxrow1 = Maxrow1 + 1
Range(Cells(1, xCol), Cells(LastRow, xCol)).Cut Cells(NextRow, 1)
countofquestions = countofquestions + 1
Maxrow1 = Maxrow1 + MaxRow
Next xCol
Sheets(2).Activate
For column = 1 To 1000
If Cells(1, column) = Empty Then
Exit For
End If

numberofjobs = MaxRow
Sheets(2).Cells(numberofjobs + 1, column) = "XXXX"
numberofjobs = numberofjobs + 1
numberofjobs1 = numberofjobs
For Count = 1 To countofquestions - 1
Range(Cells(1, column), Cells(numberofjobs, column)).Copy Cells(numberofjobs1 + 1, column)
numberofjobs1 = numberofjobs1 + numberofjobs

totalrows = numberofjobs1
Next Count
Sheets(2).Columns(column).Copy Destination:=Sheets(1).Columns(column + 1)

Next column
Application.ScreenUpdating = True
OneColumn = totalrows

End Function

Function CreateNewWordDoc(rows, crosstabcount)
    Dim wrdApp As Word.Application
    Dim wrdDoc As Word.Document
    Dim i As Integer
    Set wrdApp = CreateObject("Word.Application")
    wrdApp.Visible = True
    Set wrdDoc = wrdApp.Documents.Add
     flag = 0
     questionno = 0
     flag1d = 0
    With wrdDoc
        For i = 1 To rows
            If Cells(i, 1) = "XXXX" Then
            flag = 1
            questionno = questionno + 1
             With wrdApp.Selection
             If questionno > 1 Then
             .InsertBreak
             End If
            .ParagraphFormat.SpaceBefore = 0
            .ParagraphFormat.SpaceAfter = 0
            .ParagraphFormat.Space1
            .Font.Name = "Calibri"
            .Font.Size = 18
            .Font.Bold = True
            .Font.Italic = False
            .ParagraphFormat.Alignment = wdAlignParagraphCenter
            .TypeText Text:=Sheets(3).Cells(questionno, 1)
            .Font.Size = 14
            
            .TypeText Text:=" " & Sheets(3).Cells(questionno, 2) & " PAGE: " & Sheets(3).Cells(questionno, 3)
            .InsertStyleSeparator
            .Style = "List Continue"
            .Font.Name = "Calibri"
            .Font.Size = "12"
            .Font.Bold = True
            .ParagraphFormat.SpaceBefore = 0
            .ParagraphFormat.SpaceAfter = 0
            .ParagraphFormat.Space1
            questionenter = Sheets(1).Cells(i + 1, 1)
            .TypeText Text:=vbCrLf & vbCrLf & questionenter & " " & Sheets(3).Cells(1, 4) & vbCrLf
             End With
             flag1d = 1
            Else
            If flag1d = 0 Then
            With wrdApp.Selection
            .Font.Size = 12
            .Font.Italic = False
            .ParagraphFormat.SpaceBefore = 0
            .ParagraphFormat.SpaceAfter = 0
            .ParagraphFormat.Space1
            .TypeText Text:=vbCrLf
            .Style = "Normal_verbatim"
            .Font.Name = "Calibri"
            .Font.Size = 12
            .Font.Bold = False
            .ParagraphFormat.SpaceBefore = 0
            .ParagraphFormat.SpaceAfter = 0
            .ParagraphFormat.Space1
            Cells(i, 1) = Replace(Cells(i, 1), ". " & vbCrLf, ". ")
            Cells(i, 1) = Replace(Cells(i, 1), "." & vbCrLf, ". ")
            Cells(i, 1) = Replace(Cells(i, 1), vbCrLf, ". ")
            Cells(i, 1) = UCase(Left(Cells(i, 1), 1)) + Right(Cells(i, 1), Len(Cells(i, 1)) - 1)
            If Right(Cells(i, 1), 1) = " " Then
            Cells(i, 1) = Left(Cells(i, 1), Len(Cells(i, 1)) - 1)
            End If
            If (Right(Cells(i, 1), 1) = "." Or Right(Cells(i, 1), 1) = "?" Or Right(Cells(i, 1), 1) = "!") Then
            .TypeText Text:=Cells(i, 1) & vbCrLf
            Else
            .TypeText Text:=Cells(i, 1) & "." & vbCrLf
            End If
            '.Range.ListFormat.ApplyBulletDefault
            .InsertStyleSeparator
            End With
            If i > 1 And flag = 0 And crosstabcount > 0 Then
            For x = 1 To crosstabcount
            With wrdApp.Selection
            .ParagraphFormat.SpaceBefore = 0
            .ParagraphFormat.SpaceAfter = 0
            .Style = "List Continue 2"
            .Font.Name = "Calibri"
            .Font.Size = 9
            .Font.Bold = False
            .Font.Italic = True
            .ParagraphFormat.SpaceBefore = 0
            .ParagraphFormat.SpaceAfter = 0
            .ParagraphFormat.Space1
            .TypeText Text:=Cells(i, x + 1)
            .Font.Size = 12
            .Font.Italic = False
            .ParagraphFormat.SpaceBefore = 0
            .ParagraphFormat.SpaceAfter = 0
            .ParagraphFormat.Space1
            .ParagraphFormat.SpaceBefore = 0
            .ParagraphFormat.SpaceAfter = 0
            .TypeText Text:=vbCrLf
            .InsertStyleSeparator
            End With
            Next x
            End If
            Else
            flag1d = 0
            End If
            flag = 0
        End If
        Next i
        
        .SaveAs (ActiveWorkbook.Path + "/verbatims.doc")
        .Close ' close the document
    End With
    wrdApp.Quit ' close the Word application
    Set wrdDoc = Nothing
    Set wrdApp = Nothing
End Function